├── .Rprofile ├── .gitignore ├── README.md ├── README_files ├── unnamed-chunk-28-1.png ├── unnamed-chunk-29-1.png ├── unnamed-chunk-47-1.png ├── unnamed-chunk-53-1.png └── unnamed-chunk-55-1.png ├── example_code.R ├── functions.R ├── renv.lock ├── renv └── activate.R ├── rmd_files ├── README.Rmd ├── appendix.Rmd ├── content.Rmd ├── functions.R ├── render_rmarkdown_files.R └── slides.Rmd ├── slides.html └── solutions.R /.Rprofile: -------------------------------------------------------------------------------- 1 | source("renv/activate.R") 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | *.Rproj 6 | rmd_files/README.html 7 | renv/* 8 | !renv/activate.R -------------------------------------------------------------------------------- /README_files/unnamed-chunk-28-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moj-analytical-services/writing_functions_in_r/e316ad9d57d05e08bbce629ada34794c198dd9d1/README_files/unnamed-chunk-28-1.png -------------------------------------------------------------------------------- /README_files/unnamed-chunk-29-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moj-analytical-services/writing_functions_in_r/e316ad9d57d05e08bbce629ada34794c198dd9d1/README_files/unnamed-chunk-29-1.png -------------------------------------------------------------------------------- /README_files/unnamed-chunk-47-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moj-analytical-services/writing_functions_in_r/e316ad9d57d05e08bbce629ada34794c198dd9d1/README_files/unnamed-chunk-47-1.png -------------------------------------------------------------------------------- /README_files/unnamed-chunk-53-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moj-analytical-services/writing_functions_in_r/e316ad9d57d05e08bbce629ada34794c198dd9d1/README_files/unnamed-chunk-53-1.png -------------------------------------------------------------------------------- /README_files/unnamed-chunk-55-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moj-analytical-services/writing_functions_in_r/e316ad9d57d05e08bbce629ada34794c198dd9d1/README_files/unnamed-chunk-55-1.png -------------------------------------------------------------------------------- /example_code.R: -------------------------------------------------------------------------------- 1 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 2 | x <- c(1, 2, 3, 4, 5) # Create a vector of numbers to sum 3 | sum(x) # Sum the numbers contained in 'x' 4 | 5 | 6 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 7 | # Comment describing what the function does 8 | function_name <- function(arg1, arg2) { 9 | # function body, e.g. 10 | paste(arg1, arg2, "!") 11 | } 12 | 13 | 14 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 15 | # This function takes the argument 'x', and adds 2 to it 16 | add_two <- function(x) { 17 | 18 | x + 2 19 | 20 | } 21 | 22 | 23 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 24 | # Calling the function by itself prints the result to the console 25 | add_two(3) 26 | 27 | # Alternatively the result can be saved as a new variable 28 | result <- add_two(3) 29 | result 30 | 31 | 32 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 33 | # This function sums the squares of two numbers 34 | sum_squares <- function(x, y) { 35 | 36 | x^2 + y^2 37 | 38 | } 39 | 40 | sum_squares(3, y = 5) 41 | 42 | 43 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 44 | # Good 45 | sum_squares(3, y = 5) 46 | 47 | # Acceptable 48 | sum_squares(y = 5, x = 3) 49 | 50 | # Bad 51 | sum_squares(3, 5) 52 | 53 | 54 | 55 | 56 | 57 | 58 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 59 | # This function returns the absolute value of a number 60 | abs_x <- function(x) { 61 | if (x >= 0) { 62 | x 63 | } else { 64 | -x 65 | } 66 | } 67 | 68 | abs_x(-5) 69 | abs_x(4) 70 | 71 | 72 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 73 | # why does this function always return -x? 74 | abs_x_v2 <- function(x) { 75 | 76 | if (x >= 0) { 77 | x 78 | } 79 | 80 | -x 81 | 82 | } 83 | 84 | abs_x_v2(-5) 85 | abs_x_v2(4) 86 | 87 | 88 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 89 | # We can fix it by using an early return 90 | abs_x_v3 <- function(x) { 91 | 92 | if (x >= 0) { 93 | return(x) 94 | } 95 | 96 | -x 97 | 98 | } 99 | 100 | abs_x_v3(-5) 101 | abs_x_v3(4) 102 | 103 | 104 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 105 | # This function lets you know whether a number is odd or even 106 | odd_or_even <- function(x) { 107 | 108 | if ((x %% 2) == 0) { 109 | message("The number is even.") 110 | } else if ((x %% 2) == 1) { 111 | message("The number is odd.") 112 | } 113 | 114 | } 115 | 116 | odd_or_even(x = 4) 117 | 118 | 119 | ## ----error = TRUE, purl=purl_example_code-------------------------------------------------------------------------------------------------------- 120 | odd_or_even(x = 1.5) 121 | odd_or_even(x = "a") 122 | odd_or_even(x = c(1, 2, 3)) 123 | 124 | 125 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 126 | # This function lets you know whether a number is odd or even 127 | odd_or_even <- function(x) { 128 | if (length(x) > 1) { 129 | stop("x must have length 1.") 130 | } else if (!is.numeric(x)) { 131 | stop("x must be a number.") 132 | } else if ((x %% 2) == 0) { 133 | print("The number is even.") 134 | } else if ((x %% 2) == 1) { 135 | print("The number is odd.") 136 | } else if((x %% 2) != 0 && (x %% 2) != 1) { 137 | stop("x must be an integer.") 138 | } 139 | 140 | } 141 | 142 | 143 | ## ----error = TRUE, purl=purl_example_code-------------------------------------------------------------------------------------------------------- 144 | odd_or_even(x = 1.5) 145 | odd_or_even(x = "a") 146 | odd_or_even(x = c(1, 2, 3)) 147 | 148 | 149 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 150 | # This function either returns the sum of two numbers, or returns the argument if only one is supplied 151 | add_a_number <- function(x, y = NULL) { 152 | 153 | if (!is.null(y)) { 154 | x + y 155 | } else { 156 | x 157 | } 158 | 159 | } 160 | 161 | add_a_number(x = 6) 162 | add_a_number(x = 6, y = 7) 163 | 164 | 165 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 166 | # This function demonstrates the difference between NULL, NA and "missing" 167 | return_x <- function(x) { 168 | if (missing(x)) { 169 | message("x is missing") 170 | } 171 | if (is.null(x)) { 172 | message("x is null") 173 | } 174 | if (is.na(x)) { 175 | message("x is NA") 176 | } 177 | x 178 | } 179 | 180 | return_x(5) 181 | 182 | 183 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 184 | return_x() 185 | return_x(NULL) 186 | return_x(NA) 187 | 188 | 189 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 190 | # This function returns the sum of two numbers raised to a particular power (with a default of 2) 191 | sum_powers <- function(x, y, z = 2) { 192 | 193 | x ^ z + y ^ z 194 | 195 | } 196 | 197 | sum_powers(x = 3, y = 5) 198 | sum_powers(x = 3, y = 5, z = 3) 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 212 | # This function produces a plot of x vs y 213 | plot_x_and_y <- function(x, y, ...) { 214 | 215 | plot(x, y, ...) 216 | 217 | } 218 | 219 | x <- 1:10 220 | y <- (1:10) * 2 221 | 222 | 223 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 224 | plot_x_and_y(x, y) 225 | 226 | 227 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 228 | plot_x_and_y(x, y, col='red', type='l') 229 | 230 | 231 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 232 | iris_by_species_1 <- function(species) { 233 | datasets::iris |> filter(iris[[5]] == species) |> dplyr::glimpse() 234 | } 235 | 236 | iris_by_species_2 <- function(species) { 237 | datasets::iris |> dplyr::filter(iris[[5]] == species) |> dplyr::glimpse() 238 | } 239 | 240 | iris_by_species_1("setosa") 241 | iris_by_species_2("setosa") 242 | 243 | 244 | ## ----message=F, warning=F, purl=purl_example_code------------------------------------------------------------------------------------------------ 245 | prosecutions_and_convictions <- Rs3tools::read_using( 246 | FUN = read.csv, 247 | s3_path = "s3://alpha-r-training/writing-functions-in-r/prosecutions-and-convictions-2018.csv" 248 | ) 249 | 250 | # Filter for Magistrates Court to extract the prosecutions 251 | prosecutions <- prosecutions_and_convictions |> 252 | dplyr::filter(`Court.Type` == "Magistrates Court") 253 | 254 | 255 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 256 | dplyr::glimpse(prosecutions) 257 | 258 | 259 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 260 | # This function standardises strings contained in a vector 261 | generalise_names <- function(names) { 262 | 263 | names |> 264 | # Convert any uppercase letters to lowercase 265 | tolower() |> 266 | # Trim any blank spaces at the start or end of each string 267 | stringr::str_trim() |> 268 | # Replace anything that isn't a letter or number with an underscore 269 | stringr::str_replace_all(pattern = "[^A-Za-z0-9]", replacement = "_") |> 270 | # Remove repeated underscores 271 | stringr::str_remove_all(pattern = "(?<=_)_+") |> 272 | # Remove any underscore at the beginning or end of the string 273 | stringr::str_remove_all(pattern = "^_|_$") 274 | 275 | } 276 | 277 | 278 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 279 | names <- c("Option 1", " Option (1)", "Option: 1", "option 1", "OPTION - 1") 280 | generalise_names(names) 281 | 282 | 283 | 284 | 285 | ## ----echo=FALSE, purl=purl_example_code---------------------------------------------------------------------------------------------------------- 286 | dplyr::glimpse(prosecutions[, 1:10]) 287 | 288 | 289 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 290 | # This function removes patterns at the start of a string that are: 291 | # 1 or 2 digits followed by any number of colons and/or spaces 292 | 293 | remove_numbering <- function(x) { 294 | stringr::str_remove(x, pattern = "^\\d{1,2}\\s*:*\\s*") 295 | } 296 | 297 | 298 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 299 | 300 | some_strings <- c("01 :foo", "01 foo", "01: foo", "01 : foo", "foo", "bar foo") 301 | remove_numbering(some_strings) 302 | 303 | 304 | 305 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 306 | prosecutions <- dplyr::mutate(prosecutions, across(where(is.character), remove_numbering)) 307 | dplyr::glimpse(prosecutions) 308 | 309 | 310 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 311 | clean_not_known <- function(x, 312 | not_known_phrase = "Not known", 313 | values_to_change = c("n/a", "not known", "unknown", "not stated")) { 314 | 315 | # Replace any missing (NA) values 316 | x <- replace(x, list = is.na(x), values = not_known_phrase) 317 | 318 | # Remove any white space that might cause the strings to not match 319 | x <- stringr::str_trim(x) 320 | 321 | # Replace strings in the data that refer to a missing or unknown value. 322 | dplyr::if_else(tolower(x) %in% values_to_change, true = not_known_phrase, false = x) 323 | 324 | } 325 | 326 | 327 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 328 | prosecutions <- dplyr::mutate( 329 | prosecutions, 330 | dplyr::across( 331 | .cols = tidyselect::where(is.character), 332 | .fns = clean_not_known 333 | ) 334 | ) 335 | 336 | dplyr::glimpse(prosecutions) 337 | 338 | 339 | 340 | 341 | 342 | 343 | ## ----include=FALSE, purl=purl_example_code------------------------------------------------------------------------------------------------------- 344 | # Solution to exercise 3 - must run before the next section 345 | colnames(prosecutions) <- colnames(prosecutions) |> generalise_names() 346 | 347 | 348 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 349 | prosecutions_grouped <- prosecutions |> 350 | dplyr::group_by(age_range) |> 351 | dplyr::summarise(counts = sum(count)) 352 | 353 | 354 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 355 | prosecutions_grouped 356 | 357 | 358 | ## ----purl=purl_example_code, fig.height = 3------------------------------------------------------------------------------------------------------ 359 | foo <- 1:10 360 | bar <- 10:1 361 | plot(foo, bar) 362 | 363 | 364 | ## ----error = TRUE, purl=purl_example_code-------------------------------------------------------------------------------------------------------- 365 | # This function produces a summary table based on a dataset 366 | sum_group <- function(df, group_col, sum_col) { 367 | 368 | df |> 369 | dplyr::group_by(group_col) |> 370 | dplyr::summarise(counts = sum(sum_col)) 371 | 372 | } 373 | 374 | 375 | ## ----error = TRUE, purl=purl_example_code-------------------------------------------------------------------------------------------------------- 376 | prosecutions_grouped <- sum_group(df = prosecutions, group_col = "age_range", sum_col = "count") 377 | 378 | 379 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 380 | # This function produces a summary table based on a dataset 381 | sum_group <- function(df, group_col, sum_col) { 382 | 383 | df |> 384 | dplyr::group_by(.data[[group_col]]) |> 385 | dplyr::summarise(counts = sum(.data[[sum_col]])) 386 | 387 | } 388 | 389 | 390 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 391 | prosecutions_grouped <- sum_group(df = prosecutions, group_col = "age_range", sum_col = "count") 392 | prosecutions_grouped 393 | 394 | 395 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 396 | # This function produces a plot of the number of prosecutions over time 397 | plot_prosecutions <- function(df, breakdown = "offence_type") { 398 | 399 | df_grouped <- df |> 400 | dplyr::group_by(.data[[breakdown]], year) |> 401 | dplyr::summarise(counts = sum(count), .groups = "keep") 402 | 403 | df_grouped |> 404 | ggplot2::ggplot( 405 | ggplot2::aes(x = .data$year, 406 | y = .data$counts, 407 | group = .data[[breakdown]], 408 | col = .data[[breakdown]]) 409 | ) + 410 | ggplot2::geom_line() + 411 | ggplot2::scale_x_continuous(breaks = 0:2100) + 412 | ggplot2::theme_grey() 413 | } 414 | 415 | 416 | ## ----fig.width=10, purl=purl_example_code-------------------------------------------------------------------------------------------------------- 417 | # Call function 418 | plot_prosecutions(prosecutions, breakdown = "offence_type") 419 | 420 | 421 | 422 | 423 | 424 | 425 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 426 | my_mean <- function(x, y) { 427 | x + y / 2 428 | } 429 | 430 | my_mean(3, 5) 431 | 432 | 433 | 434 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 435 | # Function to calculate the length of a hypotenuse 436 | pythagoras <- function(a, b) { 437 | 438 | c <- sqrt(a^2 + b^2) 439 | 440 | paste0("The length of the hypotenuse is ", c) 441 | 442 | } 443 | 444 | pythagoras(2, -3) 445 | 446 | 447 | 448 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 449 | # Function to calculate the length of a hypotenuse 450 | pythagoras <- function(a, b) { 451 | 452 | assertthat::assert_that(a > 0) 453 | assertthat::assert_that(b > 0) 454 | 455 | c <- sqrt(a^2 + b^2) 456 | 457 | paste0("The length of the hypotenuse is ", c) 458 | 459 | } 460 | 461 | pythagoras(2, -3) 462 | 463 | 464 | 465 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 466 | # Function to calculate the length of a hypotenuse 467 | pythagoras <- function(a, b) { 468 | 469 | assertthat::assert_that( 470 | a > 0 && b > 0, 471 | msg = "both triangle sides must have positive length!") 472 | 473 | c <- sqrt(a^2 + b^2) 474 | 475 | paste0("The length of the hypotenuse is ", c) 476 | 477 | } 478 | 479 | pythagoras(-2, 1) 480 | 481 | 482 | 483 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 484 | # Function to calculate the length of a hypotenuse 485 | pythagoras <- function(a, b) { 486 | 487 | assertthat::assert_that( 488 | !missing(a) && !missing(b), 489 | msg = "you must supply two triangle lengths") 490 | 491 | assertthat::assert_that( 492 | is.numeric(a) && is.numeric(b), 493 | msg = "both arguments must be of numeric data type") 494 | 495 | assertthat::assert_that( 496 | a > 0 && b > 0, 497 | msg = "both triangle sides must have positive length!") 498 | 499 | sqrt(a^2 + b^2) 500 | 501 | } 502 | 503 | 504 | 505 | ## ----purl=purl_example_code, error = TRUE-------------------------------------------------------------------------------------------------------- 506 | pythagoras("1", 2) 507 | 508 | pythagoras(b = 2) 509 | 510 | 511 | ## ----purl_example_code, error = TRUE, eval = FALSE----------------------------------------------------------------------------------------------- 512 | ## # Exercise 7 assertion statement 513 | ## 514 | ## assertthat::assert_that(c %% 1 == 0) 515 | ## 516 | 517 | 518 | 519 | 520 | 521 | 522 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 523 | source("functions.R") 524 | 525 | 526 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 527 | # Create a list of colours to provide to the function 528 | colours <- c("Red", "Blue", "Green", "Magenta", "Cyan", "Yellow", "Purple", "Pink") 529 | pick_a_colour(colours) 530 | 531 | 532 | ## ----purl=purl_example_code---------------------------------------------------------------------------------------------------------------------- 533 | pick_a_colour 534 | 535 | -------------------------------------------------------------------------------- /functions.R: -------------------------------------------------------------------------------- 1 | # We can collect functions together in this R script 2 | 3 | 4 | pick_a_colour <- function(colours){ 5 | 6 | # Generate a random number between 1 and the number of colours provided 7 | x <- sample(1:length(colours), 1) 8 | 9 | # Print a randomly chosen colour 10 | print(colours[x]) 11 | 12 | } -------------------------------------------------------------------------------- /renv.lock: -------------------------------------------------------------------------------- 1 | { 2 | "R": { 3 | "Version": "4.4.0", 4 | "Repositories": [ 5 | { 6 | "Name": "CRAN", 7 | "URL": "https://p3m.dev/cran/latest" 8 | } 9 | ] 10 | }, 11 | "Packages": { 12 | "MASS": { 13 | "Package": "MASS", 14 | "Version": "7.3-60.2", 15 | "Source": "Repository", 16 | "Repository": "CRAN", 17 | "Requirements": [ 18 | "R", 19 | "grDevices", 20 | "graphics", 21 | "methods", 22 | "stats", 23 | "utils" 24 | ], 25 | "Hash": "2f342c46163b0b54d7b64d1f798e2c78" 26 | }, 27 | "Matrix": { 28 | "Package": "Matrix", 29 | "Version": "1.7-0", 30 | "Source": "Repository", 31 | "Repository": "CRAN", 32 | "Requirements": [ 33 | "R", 34 | "grDevices", 35 | "graphics", 36 | "grid", 37 | "lattice", 38 | "methods", 39 | "stats", 40 | "utils" 41 | ], 42 | "Hash": "1920b2f11133b12350024297d8a4ff4a" 43 | }, 44 | "R6": { 45 | "Package": "R6", 46 | "Version": "2.5.1", 47 | "Source": "Repository", 48 | "Repository": "RSPM", 49 | "Requirements": [ 50 | "R" 51 | ], 52 | "Hash": "470851b6d5d0ac559e9d01bb352b4021" 53 | }, 54 | "RColorBrewer": { 55 | "Package": "RColorBrewer", 56 | "Version": "1.1-3", 57 | "Source": "Repository", 58 | "Repository": "RSPM", 59 | "Requirements": [ 60 | "R" 61 | ], 62 | "Hash": "45f0398006e83a5b10b72a90663d8d8c" 63 | }, 64 | "Rcpp": { 65 | "Package": "Rcpp", 66 | "Version": "1.0.12", 67 | "Source": "Repository", 68 | "Repository": "RSPM", 69 | "Requirements": [ 70 | "methods", 71 | "utils" 72 | ], 73 | "Hash": "5ea2700d21e038ace58269ecdbeb9ec0" 74 | }, 75 | "Rs3tools": { 76 | "Package": "Rs3tools", 77 | "Version": "0.4.4", 78 | "Source": "GitHub", 79 | "RemoteType": "github", 80 | "RemoteHost": "api.github.com", 81 | "RemoteUsername": "moj-analytical-services", 82 | "RemoteRepo": "Rs3tools", 83 | "RemoteRef": "main", 84 | "RemoteSha": "53078744d0e96be8e3d3865f9ebdddc4e21cfb04", 85 | "Requirements": [ 86 | "dplyr", 87 | "gdata", 88 | "glue", 89 | "httr", 90 | "magrittr", 91 | "paws", 92 | "purrr", 93 | "readr", 94 | "rlang", 95 | "stringr", 96 | "tibble", 97 | "tools", 98 | "utils" 99 | ], 100 | "Hash": "b9cac31bc707f94d1c90a2da7cd0d70d" 101 | }, 102 | "askpass": { 103 | "Package": "askpass", 104 | "Version": "1.2.0", 105 | "Source": "Repository", 106 | "Repository": "RSPM", 107 | "Requirements": [ 108 | "sys" 109 | ], 110 | "Hash": "cad6cf7f1d5f6e906700b9d3e718c796" 111 | }, 112 | "assertthat": { 113 | "Package": "assertthat", 114 | "Version": "0.2.1", 115 | "Source": "Repository", 116 | "Repository": "RSPM", 117 | "Requirements": [ 118 | "tools" 119 | ], 120 | "Hash": "50c838a310445e954bc13f26f26a6ecf" 121 | }, 122 | "base64enc": { 123 | "Package": "base64enc", 124 | "Version": "0.1-3", 125 | "Source": "Repository", 126 | "Repository": "RSPM", 127 | "Requirements": [ 128 | "R" 129 | ], 130 | "Hash": "543776ae6848fde2f48ff3816d0628bc" 131 | }, 132 | "bit": { 133 | "Package": "bit", 134 | "Version": "4.0.5", 135 | "Source": "Repository", 136 | "Repository": "RSPM", 137 | "Requirements": [ 138 | "R" 139 | ], 140 | "Hash": "d242abec29412ce988848d0294b208fd" 141 | }, 142 | "bit64": { 143 | "Package": "bit64", 144 | "Version": "4.0.5", 145 | "Source": "Repository", 146 | "Repository": "RSPM", 147 | "Requirements": [ 148 | "R", 149 | "bit", 150 | "methods", 151 | "stats", 152 | "utils" 153 | ], 154 | "Hash": "9fe98599ca456d6552421db0d6772d8f" 155 | }, 156 | "bslib": { 157 | "Package": "bslib", 158 | "Version": "0.7.0", 159 | "Source": "Repository", 160 | "Repository": "RSPM", 161 | "Requirements": [ 162 | "R", 163 | "base64enc", 164 | "cachem", 165 | "fastmap", 166 | "grDevices", 167 | "htmltools", 168 | "jquerylib", 169 | "jsonlite", 170 | "lifecycle", 171 | "memoise", 172 | "mime", 173 | "rlang", 174 | "sass" 175 | ], 176 | "Hash": "8644cc53f43828f19133548195d7e59e" 177 | }, 178 | "cachem": { 179 | "Package": "cachem", 180 | "Version": "1.1.0", 181 | "Source": "Repository", 182 | "Repository": "CRAN", 183 | "Requirements": [ 184 | "fastmap", 185 | "rlang" 186 | ], 187 | "Hash": "cd9a672193789068eb5a2aad65a0dedf" 188 | }, 189 | "cli": { 190 | "Package": "cli", 191 | "Version": "3.6.3", 192 | "Source": "Repository", 193 | "Repository": "CRAN", 194 | "Requirements": [ 195 | "R", 196 | "utils" 197 | ], 198 | "Hash": "b21916dd77a27642b447374a5d30ecf3" 199 | }, 200 | "clipr": { 201 | "Package": "clipr", 202 | "Version": "0.8.0", 203 | "Source": "Repository", 204 | "Repository": "RSPM", 205 | "Requirements": [ 206 | "utils" 207 | ], 208 | "Hash": "3f038e5ac7f41d4ac41ce658c85e3042" 209 | }, 210 | "colorspace": { 211 | "Package": "colorspace", 212 | "Version": "2.1-0", 213 | "Source": "Repository", 214 | "Repository": "RSPM", 215 | "Requirements": [ 216 | "R", 217 | "grDevices", 218 | "graphics", 219 | "methods", 220 | "stats" 221 | ], 222 | "Hash": "f20c47fd52fae58b4e377c37bb8c335b" 223 | }, 224 | "cpp11": { 225 | "Package": "cpp11", 226 | "Version": "0.4.7", 227 | "Source": "Repository", 228 | "Repository": "RSPM", 229 | "Requirements": [ 230 | "R" 231 | ], 232 | "Hash": "5a295d7d963cc5035284dcdbaf334f4e" 233 | }, 234 | "crayon": { 235 | "Package": "crayon", 236 | "Version": "1.5.3", 237 | "Source": "Repository", 238 | "Repository": "CRAN", 239 | "Requirements": [ 240 | "grDevices", 241 | "methods", 242 | "utils" 243 | ], 244 | "Hash": "859d96e65ef198fd43e82b9628d593ef" 245 | }, 246 | "curl": { 247 | "Package": "curl", 248 | "Version": "5.2.1", 249 | "Source": "Repository", 250 | "Repository": "RSPM", 251 | "Requirements": [ 252 | "R" 253 | ], 254 | "Hash": "411ca2c03b1ce5f548345d2fc2685f7a" 255 | }, 256 | "digest": { 257 | "Package": "digest", 258 | "Version": "0.6.36", 259 | "Source": "Repository", 260 | "Repository": "CRAN", 261 | "Requirements": [ 262 | "R", 263 | "utils" 264 | ], 265 | "Hash": "fd6824ad91ede64151e93af67df6376b" 266 | }, 267 | "dplyr": { 268 | "Package": "dplyr", 269 | "Version": "1.1.4", 270 | "Source": "Repository", 271 | "Repository": "RSPM", 272 | "Requirements": [ 273 | "R", 274 | "R6", 275 | "cli", 276 | "generics", 277 | "glue", 278 | "lifecycle", 279 | "magrittr", 280 | "methods", 281 | "pillar", 282 | "rlang", 283 | "tibble", 284 | "tidyselect", 285 | "utils", 286 | "vctrs" 287 | ], 288 | "Hash": "fedd9d00c2944ff00a0e2696ccf048ec" 289 | }, 290 | "evaluate": { 291 | "Package": "evaluate", 292 | "Version": "0.24.0", 293 | "Source": "Repository", 294 | "Repository": "CRAN", 295 | "Requirements": [ 296 | "R", 297 | "methods" 298 | ], 299 | "Hash": "a1066cbc05caee9a4bf6d90f194ff4da" 300 | }, 301 | "fansi": { 302 | "Package": "fansi", 303 | "Version": "1.0.6", 304 | "Source": "Repository", 305 | "Repository": "RSPM", 306 | "Requirements": [ 307 | "R", 308 | "grDevices", 309 | "utils" 310 | ], 311 | "Hash": "962174cf2aeb5b9eea581522286a911f" 312 | }, 313 | "farver": { 314 | "Package": "farver", 315 | "Version": "2.1.2", 316 | "Source": "Repository", 317 | "Repository": "CRAN", 318 | "Hash": "680887028577f3fa2a81e410ed0d6e42" 319 | }, 320 | "fastmap": { 321 | "Package": "fastmap", 322 | "Version": "1.2.0", 323 | "Source": "Repository", 324 | "Repository": "CRAN", 325 | "Hash": "aa5e1cd11c2d15497494c5292d7ffcc8" 326 | }, 327 | "fontawesome": { 328 | "Package": "fontawesome", 329 | "Version": "0.5.2", 330 | "Source": "Repository", 331 | "Repository": "RSPM", 332 | "Requirements": [ 333 | "R", 334 | "htmltools", 335 | "rlang" 336 | ], 337 | "Hash": "c2efdd5f0bcd1ea861c2d4e2a883a67d" 338 | }, 339 | "fs": { 340 | "Package": "fs", 341 | "Version": "1.6.4", 342 | "Source": "Repository", 343 | "Repository": "RSPM", 344 | "Requirements": [ 345 | "R", 346 | "methods" 347 | ], 348 | "Hash": "15aeb8c27f5ea5161f9f6a641fafd93a" 349 | }, 350 | "gdata": { 351 | "Package": "gdata", 352 | "Version": "3.0.0", 353 | "Source": "Repository", 354 | "Repository": "CRAN", 355 | "Requirements": [ 356 | "gtools", 357 | "methods", 358 | "stats", 359 | "utils" 360 | ], 361 | "Hash": "d3d6e4c174b8a5f251fd273f245f2471" 362 | }, 363 | "generics": { 364 | "Package": "generics", 365 | "Version": "0.1.3", 366 | "Source": "Repository", 367 | "Repository": "RSPM", 368 | "Requirements": [ 369 | "R", 370 | "methods" 371 | ], 372 | "Hash": "15e9634c0fcd294799e9b2e929ed1b86" 373 | }, 374 | "ggplot2": { 375 | "Package": "ggplot2", 376 | "Version": "3.5.1", 377 | "Source": "Repository", 378 | "Repository": "RSPM", 379 | "Requirements": [ 380 | "MASS", 381 | "R", 382 | "cli", 383 | "glue", 384 | "grDevices", 385 | "grid", 386 | "gtable", 387 | "isoband", 388 | "lifecycle", 389 | "mgcv", 390 | "rlang", 391 | "scales", 392 | "stats", 393 | "tibble", 394 | "vctrs", 395 | "withr" 396 | ], 397 | "Hash": "44c6a2f8202d5b7e878ea274b1092426" 398 | }, 399 | "glue": { 400 | "Package": "glue", 401 | "Version": "1.7.0", 402 | "Source": "Repository", 403 | "Repository": "RSPM", 404 | "Requirements": [ 405 | "R", 406 | "methods" 407 | ], 408 | "Hash": "e0b3a53876554bd45879e596cdb10a52" 409 | }, 410 | "gtable": { 411 | "Package": "gtable", 412 | "Version": "0.3.5", 413 | "Source": "Repository", 414 | "Repository": "RSPM", 415 | "Requirements": [ 416 | "R", 417 | "cli", 418 | "glue", 419 | "grid", 420 | "lifecycle", 421 | "rlang" 422 | ], 423 | "Hash": "e18861963cbc65a27736e02b3cd3c4a0" 424 | }, 425 | "gtools": { 426 | "Package": "gtools", 427 | "Version": "3.9.5", 428 | "Source": "Repository", 429 | "Repository": "CRAN", 430 | "Requirements": [ 431 | "methods", 432 | "stats", 433 | "utils" 434 | ], 435 | "Hash": "588d091c35389f1f4a9d533c8d709b35" 436 | }, 437 | "here": { 438 | "Package": "here", 439 | "Version": "1.0.1", 440 | "Source": "Repository", 441 | "Repository": "CRAN", 442 | "Requirements": [ 443 | "rprojroot" 444 | ], 445 | "Hash": "24b224366f9c2e7534d2344d10d59211" 446 | }, 447 | "highr": { 448 | "Package": "highr", 449 | "Version": "0.11", 450 | "Source": "Repository", 451 | "Repository": "CRAN", 452 | "Requirements": [ 453 | "R", 454 | "xfun" 455 | ], 456 | "Hash": "d65ba49117ca223614f71b60d85b8ab7" 457 | }, 458 | "hms": { 459 | "Package": "hms", 460 | "Version": "1.1.3", 461 | "Source": "Repository", 462 | "Repository": "RSPM", 463 | "Requirements": [ 464 | "lifecycle", 465 | "methods", 466 | "pkgconfig", 467 | "rlang", 468 | "vctrs" 469 | ], 470 | "Hash": "b59377caa7ed00fa41808342002138f9" 471 | }, 472 | "htmltools": { 473 | "Package": "htmltools", 474 | "Version": "0.5.8.1", 475 | "Source": "Repository", 476 | "Repository": "RSPM", 477 | "Requirements": [ 478 | "R", 479 | "base64enc", 480 | "digest", 481 | "fastmap", 482 | "grDevices", 483 | "rlang", 484 | "utils" 485 | ], 486 | "Hash": "81d371a9cc60640e74e4ab6ac46dcedc" 487 | }, 488 | "httr": { 489 | "Package": "httr", 490 | "Version": "1.4.7", 491 | "Source": "Repository", 492 | "Repository": "CRAN", 493 | "Requirements": [ 494 | "R", 495 | "R6", 496 | "curl", 497 | "jsonlite", 498 | "mime", 499 | "openssl" 500 | ], 501 | "Hash": "ac107251d9d9fd72f0ca8049988f1d7f" 502 | }, 503 | "isoband": { 504 | "Package": "isoband", 505 | "Version": "0.2.7", 506 | "Source": "Repository", 507 | "Repository": "RSPM", 508 | "Requirements": [ 509 | "grid", 510 | "utils" 511 | ], 512 | "Hash": "0080607b4a1a7b28979aecef976d8bc2" 513 | }, 514 | "janitor": { 515 | "Package": "janitor", 516 | "Version": "2.2.0", 517 | "Source": "Repository", 518 | "Repository": "CRAN", 519 | "Requirements": [ 520 | "R", 521 | "dplyr", 522 | "hms", 523 | "lifecycle", 524 | "lubridate", 525 | "magrittr", 526 | "purrr", 527 | "rlang", 528 | "snakecase", 529 | "stringi", 530 | "stringr", 531 | "tidyr", 532 | "tidyselect" 533 | ], 534 | "Hash": "5baae149f1082f466df9d1442ba7aa65" 535 | }, 536 | "jquerylib": { 537 | "Package": "jquerylib", 538 | "Version": "0.1.4", 539 | "Source": "Repository", 540 | "Repository": "RSPM", 541 | "Requirements": [ 542 | "htmltools" 543 | ], 544 | "Hash": "5aab57a3bd297eee1c1d862735972182" 545 | }, 546 | "jsonlite": { 547 | "Package": "jsonlite", 548 | "Version": "1.8.8", 549 | "Source": "Repository", 550 | "Repository": "RSPM", 551 | "Requirements": [ 552 | "methods" 553 | ], 554 | "Hash": "e1b9c55281c5adc4dd113652d9e26768" 555 | }, 556 | "knitr": { 557 | "Package": "knitr", 558 | "Version": "1.47", 559 | "Source": "Repository", 560 | "Repository": "CRAN", 561 | "Requirements": [ 562 | "R", 563 | "evaluate", 564 | "highr", 565 | "methods", 566 | "tools", 567 | "xfun", 568 | "yaml" 569 | ], 570 | "Hash": "7c99b2d55584b982717fcc0950378612" 571 | }, 572 | "labeling": { 573 | "Package": "labeling", 574 | "Version": "0.4.3", 575 | "Source": "Repository", 576 | "Repository": "RSPM", 577 | "Requirements": [ 578 | "graphics", 579 | "stats" 580 | ], 581 | "Hash": "b64ec208ac5bc1852b285f665d6368b3" 582 | }, 583 | "lattice": { 584 | "Package": "lattice", 585 | "Version": "0.22-6", 586 | "Source": "Repository", 587 | "Repository": "CRAN", 588 | "Requirements": [ 589 | "R", 590 | "grDevices", 591 | "graphics", 592 | "grid", 593 | "stats", 594 | "utils" 595 | ], 596 | "Hash": "cc5ac1ba4c238c7ca9fa6a87ca11a7e2" 597 | }, 598 | "lifecycle": { 599 | "Package": "lifecycle", 600 | "Version": "1.0.4", 601 | "Source": "Repository", 602 | "Repository": "RSPM", 603 | "Requirements": [ 604 | "R", 605 | "cli", 606 | "glue", 607 | "rlang" 608 | ], 609 | "Hash": "b8552d117e1b808b09a832f589b79035" 610 | }, 611 | "lubridate": { 612 | "Package": "lubridate", 613 | "Version": "1.9.3", 614 | "Source": "Repository", 615 | "Repository": "RSPM", 616 | "Requirements": [ 617 | "R", 618 | "generics", 619 | "methods", 620 | "timechange" 621 | ], 622 | "Hash": "680ad542fbcf801442c83a6ac5a2126c" 623 | }, 624 | "magrittr": { 625 | "Package": "magrittr", 626 | "Version": "2.0.3", 627 | "Source": "Repository", 628 | "Repository": "RSPM", 629 | "Requirements": [ 630 | "R" 631 | ], 632 | "Hash": "7ce2733a9826b3aeb1775d56fd305472" 633 | }, 634 | "memoise": { 635 | "Package": "memoise", 636 | "Version": "2.0.1", 637 | "Source": "Repository", 638 | "Repository": "RSPM", 639 | "Requirements": [ 640 | "cachem", 641 | "rlang" 642 | ], 643 | "Hash": "e2817ccf4a065c5d9d7f2cfbe7c1d78c" 644 | }, 645 | "mgcv": { 646 | "Package": "mgcv", 647 | "Version": "1.9-1", 648 | "Source": "Repository", 649 | "Repository": "CRAN", 650 | "Requirements": [ 651 | "Matrix", 652 | "R", 653 | "graphics", 654 | "methods", 655 | "nlme", 656 | "splines", 657 | "stats", 658 | "utils" 659 | ], 660 | "Hash": "110ee9d83b496279960e162ac97764ce" 661 | }, 662 | "mime": { 663 | "Package": "mime", 664 | "Version": "0.12", 665 | "Source": "Repository", 666 | "Repository": "RSPM", 667 | "Requirements": [ 668 | "tools" 669 | ], 670 | "Hash": "18e9c28c1d3ca1560ce30658b22ce104" 671 | }, 672 | "munsell": { 673 | "Package": "munsell", 674 | "Version": "0.5.1", 675 | "Source": "Repository", 676 | "Repository": "RSPM", 677 | "Requirements": [ 678 | "colorspace", 679 | "methods" 680 | ], 681 | "Hash": "4fd8900853b746af55b81fda99da7695" 682 | }, 683 | "nlme": { 684 | "Package": "nlme", 685 | "Version": "3.1-164", 686 | "Source": "Repository", 687 | "Repository": "CRAN", 688 | "Requirements": [ 689 | "R", 690 | "graphics", 691 | "lattice", 692 | "stats", 693 | "utils" 694 | ], 695 | "Hash": "a623a2239e642806158bc4dc3f51565d" 696 | }, 697 | "openssl": { 698 | "Package": "openssl", 699 | "Version": "2.2.0", 700 | "Source": "Repository", 701 | "Repository": "RSPM", 702 | "Requirements": [ 703 | "askpass" 704 | ], 705 | "Hash": "2bcca3848e4734eb3b16103bc9aa4b8e" 706 | }, 707 | "paws": { 708 | "Package": "paws", 709 | "Version": "0.6.0", 710 | "Source": "Repository", 711 | "Repository": "CRAN", 712 | "Requirements": [ 713 | "paws.analytics", 714 | "paws.application.integration", 715 | "paws.common", 716 | "paws.compute", 717 | "paws.cost.management", 718 | "paws.customer.engagement", 719 | "paws.database", 720 | "paws.developer.tools", 721 | "paws.end.user.computing", 722 | "paws.machine.learning", 723 | "paws.management", 724 | "paws.networking", 725 | "paws.security.identity", 726 | "paws.storage" 727 | ], 728 | "Hash": "6260ba57b1cfca3ed9e74d56441730eb" 729 | }, 730 | "paws.analytics": { 731 | "Package": "paws.analytics", 732 | "Version": "0.6.0", 733 | "Source": "Repository", 734 | "Repository": "CRAN", 735 | "Requirements": [ 736 | "paws.common" 737 | ], 738 | "Hash": "d8ea9a4dfefe8a49eceff027e053aa2f" 739 | }, 740 | "paws.application.integration": { 741 | "Package": "paws.application.integration", 742 | "Version": "0.6.0", 743 | "Source": "Repository", 744 | "Repository": "CRAN", 745 | "Requirements": [ 746 | "paws.common" 747 | ], 748 | "Hash": "4a768547ec143a4a0742b33929010da4" 749 | }, 750 | "paws.common": { 751 | "Package": "paws.common", 752 | "Version": "0.7.3", 753 | "Source": "Repository", 754 | "Repository": "CRAN", 755 | "Requirements": [ 756 | "Rcpp", 757 | "base64enc", 758 | "curl", 759 | "digest", 760 | "httr", 761 | "jsonlite", 762 | "methods", 763 | "stats", 764 | "utils", 765 | "xml2" 766 | ], 767 | "Hash": "cac0fa401210ea975f052359afa894e2" 768 | }, 769 | "paws.compute": { 770 | "Package": "paws.compute", 771 | "Version": "0.6.1", 772 | "Source": "Repository", 773 | "Repository": "CRAN", 774 | "Requirements": [ 775 | "paws.common" 776 | ], 777 | "Hash": "f9a130a8f63986177bd497037b2e0447" 778 | }, 779 | "paws.cost.management": { 780 | "Package": "paws.cost.management", 781 | "Version": "0.6.1", 782 | "Source": "Repository", 783 | "Repository": "CRAN", 784 | "Requirements": [ 785 | "paws.common" 786 | ], 787 | "Hash": "756e7414ddce9aecc9a33650ac60c903" 788 | }, 789 | "paws.customer.engagement": { 790 | "Package": "paws.customer.engagement", 791 | "Version": "0.6.0", 792 | "Source": "Repository", 793 | "Repository": "CRAN", 794 | "Requirements": [ 795 | "paws.common" 796 | ], 797 | "Hash": "ff913af420713815ade6aec300c0390d" 798 | }, 799 | "paws.database": { 800 | "Package": "paws.database", 801 | "Version": "0.6.0", 802 | "Source": "Repository", 803 | "Repository": "CRAN", 804 | "Requirements": [ 805 | "paws.common" 806 | ], 807 | "Hash": "f46bbfaad83b675c56b19a44555a0a45" 808 | }, 809 | "paws.developer.tools": { 810 | "Package": "paws.developer.tools", 811 | "Version": "0.6.0", 812 | "Source": "Repository", 813 | "Repository": "CRAN", 814 | "Requirements": [ 815 | "paws.common" 816 | ], 817 | "Hash": "6e32fbe7df12ab9d3376865032218d55" 818 | }, 819 | "paws.end.user.computing": { 820 | "Package": "paws.end.user.computing", 821 | "Version": "0.6.0", 822 | "Source": "Repository", 823 | "Repository": "CRAN", 824 | "Requirements": [ 825 | "paws.common" 826 | ], 827 | "Hash": "e9de6ac1785b5f2520184f6aec59ac61" 828 | }, 829 | "paws.machine.learning": { 830 | "Package": "paws.machine.learning", 831 | "Version": "0.6.0", 832 | "Source": "Repository", 833 | "Repository": "CRAN", 834 | "Requirements": [ 835 | "paws.common" 836 | ], 837 | "Hash": "4d6b5c39490c366bdba2783f9c2727dd" 838 | }, 839 | "paws.management": { 840 | "Package": "paws.management", 841 | "Version": "0.6.1", 842 | "Source": "Repository", 843 | "Repository": "CRAN", 844 | "Requirements": [ 845 | "paws.common" 846 | ], 847 | "Hash": "3ded918fc46f96877fa3e00168de518e" 848 | }, 849 | "paws.networking": { 850 | "Package": "paws.networking", 851 | "Version": "0.6.0", 852 | "Source": "Repository", 853 | "Repository": "CRAN", 854 | "Requirements": [ 855 | "paws.common" 856 | ], 857 | "Hash": "c21930277e2d5a74937bcdf1dc0fc574" 858 | }, 859 | "paws.security.identity": { 860 | "Package": "paws.security.identity", 861 | "Version": "0.6.1", 862 | "Source": "Repository", 863 | "Repository": "CRAN", 864 | "Requirements": [ 865 | "paws.common" 866 | ], 867 | "Hash": "48f2f348334a7186a73bb8d58420baed" 868 | }, 869 | "paws.storage": { 870 | "Package": "paws.storage", 871 | "Version": "0.6.0", 872 | "Source": "Repository", 873 | "Repository": "CRAN", 874 | "Requirements": [ 875 | "paws.common" 876 | ], 877 | "Hash": "86a93407f22e5855723b83988a142dcb" 878 | }, 879 | "pillar": { 880 | "Package": "pillar", 881 | "Version": "1.9.0", 882 | "Source": "Repository", 883 | "Repository": "RSPM", 884 | "Requirements": [ 885 | "cli", 886 | "fansi", 887 | "glue", 888 | "lifecycle", 889 | "rlang", 890 | "utf8", 891 | "utils", 892 | "vctrs" 893 | ], 894 | "Hash": "15da5a8412f317beeee6175fbc76f4bb" 895 | }, 896 | "pkgconfig": { 897 | "Package": "pkgconfig", 898 | "Version": "2.0.3", 899 | "Source": "Repository", 900 | "Repository": "RSPM", 901 | "Requirements": [ 902 | "utils" 903 | ], 904 | "Hash": "01f28d4278f15c76cddbea05899c5d6f" 905 | }, 906 | "prettyunits": { 907 | "Package": "prettyunits", 908 | "Version": "1.2.0", 909 | "Source": "Repository", 910 | "Repository": "RSPM", 911 | "Requirements": [ 912 | "R" 913 | ], 914 | "Hash": "6b01fc98b1e86c4f705ce9dcfd2f57c7" 915 | }, 916 | "progress": { 917 | "Package": "progress", 918 | "Version": "1.2.3", 919 | "Source": "Repository", 920 | "Repository": "RSPM", 921 | "Requirements": [ 922 | "R", 923 | "R6", 924 | "crayon", 925 | "hms", 926 | "prettyunits" 927 | ], 928 | "Hash": "f4625e061cb2865f111b47ff163a5ca6" 929 | }, 930 | "purrr": { 931 | "Package": "purrr", 932 | "Version": "1.0.2", 933 | "Source": "Repository", 934 | "Repository": "RSPM", 935 | "Requirements": [ 936 | "R", 937 | "cli", 938 | "lifecycle", 939 | "magrittr", 940 | "rlang", 941 | "vctrs" 942 | ], 943 | "Hash": "1cba04a4e9414bdefc9dcaa99649a8dc" 944 | }, 945 | "rappdirs": { 946 | "Package": "rappdirs", 947 | "Version": "0.3.3", 948 | "Source": "Repository", 949 | "Repository": "RSPM", 950 | "Requirements": [ 951 | "R" 952 | ], 953 | "Hash": "5e3c5dc0b071b21fa128676560dbe94d" 954 | }, 955 | "readr": { 956 | "Package": "readr", 957 | "Version": "2.1.5", 958 | "Source": "Repository", 959 | "Repository": "RSPM", 960 | "Requirements": [ 961 | "R", 962 | "R6", 963 | "cli", 964 | "clipr", 965 | "cpp11", 966 | "crayon", 967 | "hms", 968 | "lifecycle", 969 | "methods", 970 | "rlang", 971 | "tibble", 972 | "tzdb", 973 | "utils", 974 | "vroom" 975 | ], 976 | "Hash": "9de96463d2117f6ac49980577939dfb3" 977 | }, 978 | "renv": { 979 | "Package": "renv", 980 | "Version": "1.0.7", 981 | "Source": "Repository", 982 | "Repository": "CRAN", 983 | "Requirements": [ 984 | "utils" 985 | ], 986 | "Hash": "397b7b2a265bc5a7a06852524dabae20" 987 | }, 988 | "rlang": { 989 | "Package": "rlang", 990 | "Version": "1.1.4", 991 | "Source": "Repository", 992 | "Repository": "CRAN", 993 | "Requirements": [ 994 | "R", 995 | "utils" 996 | ], 997 | "Hash": "3eec01f8b1dee337674b2e34ab1f9bc1" 998 | }, 999 | "rmarkdown": { 1000 | "Package": "rmarkdown", 1001 | "Version": "2.27", 1002 | "Source": "Repository", 1003 | "Repository": "CRAN", 1004 | "Requirements": [ 1005 | "R", 1006 | "bslib", 1007 | "evaluate", 1008 | "fontawesome", 1009 | "htmltools", 1010 | "jquerylib", 1011 | "jsonlite", 1012 | "knitr", 1013 | "methods", 1014 | "tinytex", 1015 | "tools", 1016 | "utils", 1017 | "xfun", 1018 | "yaml" 1019 | ], 1020 | "Hash": "27f9502e1cdbfa195f94e03b0f517484" 1021 | }, 1022 | "rprojroot": { 1023 | "Package": "rprojroot", 1024 | "Version": "2.0.4", 1025 | "Source": "Repository", 1026 | "Repository": "CRAN", 1027 | "Requirements": [ 1028 | "R" 1029 | ], 1030 | "Hash": "4c8415e0ec1e29f3f4f6fc108bef0144" 1031 | }, 1032 | "sass": { 1033 | "Package": "sass", 1034 | "Version": "0.4.9", 1035 | "Source": "Repository", 1036 | "Repository": "RSPM", 1037 | "Requirements": [ 1038 | "R6", 1039 | "fs", 1040 | "htmltools", 1041 | "rappdirs", 1042 | "rlang" 1043 | ], 1044 | "Hash": "d53dbfddf695303ea4ad66f86e99b95d" 1045 | }, 1046 | "scales": { 1047 | "Package": "scales", 1048 | "Version": "1.3.0", 1049 | "Source": "Repository", 1050 | "Repository": "RSPM", 1051 | "Requirements": [ 1052 | "R", 1053 | "R6", 1054 | "RColorBrewer", 1055 | "cli", 1056 | "farver", 1057 | "glue", 1058 | "labeling", 1059 | "lifecycle", 1060 | "munsell", 1061 | "rlang", 1062 | "viridisLite" 1063 | ], 1064 | "Hash": "c19df082ba346b0ffa6f833e92de34d1" 1065 | }, 1066 | "snakecase": { 1067 | "Package": "snakecase", 1068 | "Version": "0.11.1", 1069 | "Source": "Repository", 1070 | "Repository": "CRAN", 1071 | "Requirements": [ 1072 | "R", 1073 | "stringi", 1074 | "stringr" 1075 | ], 1076 | "Hash": "58767e44739b76965332e8a4fe3f91f1" 1077 | }, 1078 | "stringi": { 1079 | "Package": "stringi", 1080 | "Version": "1.8.4", 1081 | "Source": "Repository", 1082 | "Repository": "RSPM", 1083 | "Requirements": [ 1084 | "R", 1085 | "stats", 1086 | "tools", 1087 | "utils" 1088 | ], 1089 | "Hash": "39e1144fd75428983dc3f63aa53dfa91" 1090 | }, 1091 | "stringr": { 1092 | "Package": "stringr", 1093 | "Version": "1.5.1", 1094 | "Source": "Repository", 1095 | "Repository": "RSPM", 1096 | "Requirements": [ 1097 | "R", 1098 | "cli", 1099 | "glue", 1100 | "lifecycle", 1101 | "magrittr", 1102 | "rlang", 1103 | "stringi", 1104 | "vctrs" 1105 | ], 1106 | "Hash": "960e2ae9e09656611e0b8214ad543207" 1107 | }, 1108 | "sys": { 1109 | "Package": "sys", 1110 | "Version": "3.4.2", 1111 | "Source": "Repository", 1112 | "Repository": "RSPM", 1113 | "Hash": "3a1be13d68d47a8cd0bfd74739ca1555" 1114 | }, 1115 | "tibble": { 1116 | "Package": "tibble", 1117 | "Version": "3.2.1", 1118 | "Source": "Repository", 1119 | "Repository": "RSPM", 1120 | "Requirements": [ 1121 | "R", 1122 | "fansi", 1123 | "lifecycle", 1124 | "magrittr", 1125 | "methods", 1126 | "pillar", 1127 | "pkgconfig", 1128 | "rlang", 1129 | "utils", 1130 | "vctrs" 1131 | ], 1132 | "Hash": "a84e2cc86d07289b3b6f5069df7a004c" 1133 | }, 1134 | "tidyr": { 1135 | "Package": "tidyr", 1136 | "Version": "1.3.1", 1137 | "Source": "Repository", 1138 | "Repository": "RSPM", 1139 | "Requirements": [ 1140 | "R", 1141 | "cli", 1142 | "cpp11", 1143 | "dplyr", 1144 | "glue", 1145 | "lifecycle", 1146 | "magrittr", 1147 | "purrr", 1148 | "rlang", 1149 | "stringr", 1150 | "tibble", 1151 | "tidyselect", 1152 | "utils", 1153 | "vctrs" 1154 | ], 1155 | "Hash": "915fb7ce036c22a6a33b5a8adb712eb1" 1156 | }, 1157 | "tidyselect": { 1158 | "Package": "tidyselect", 1159 | "Version": "1.2.1", 1160 | "Source": "Repository", 1161 | "Repository": "RSPM", 1162 | "Requirements": [ 1163 | "R", 1164 | "cli", 1165 | "glue", 1166 | "lifecycle", 1167 | "rlang", 1168 | "vctrs", 1169 | "withr" 1170 | ], 1171 | "Hash": "829f27b9c4919c16b593794a6344d6c0" 1172 | }, 1173 | "timechange": { 1174 | "Package": "timechange", 1175 | "Version": "0.3.0", 1176 | "Source": "Repository", 1177 | "Repository": "RSPM", 1178 | "Requirements": [ 1179 | "R", 1180 | "cpp11" 1181 | ], 1182 | "Hash": "c5f3c201b931cd6474d17d8700ccb1c8" 1183 | }, 1184 | "tinytex": { 1185 | "Package": "tinytex", 1186 | "Version": "0.51", 1187 | "Source": "Repository", 1188 | "Repository": "RSPM", 1189 | "Requirements": [ 1190 | "xfun" 1191 | ], 1192 | "Hash": "d44e2fcd2e4e076f0aac540208559d1d" 1193 | }, 1194 | "tzdb": { 1195 | "Package": "tzdb", 1196 | "Version": "0.4.0", 1197 | "Source": "Repository", 1198 | "Repository": "RSPM", 1199 | "Requirements": [ 1200 | "R", 1201 | "cpp11" 1202 | ], 1203 | "Hash": "f561504ec2897f4d46f0c7657e488ae1" 1204 | }, 1205 | "utf8": { 1206 | "Package": "utf8", 1207 | "Version": "1.2.4", 1208 | "Source": "Repository", 1209 | "Repository": "RSPM", 1210 | "Requirements": [ 1211 | "R" 1212 | ], 1213 | "Hash": "62b65c52671e6665f803ff02954446e9" 1214 | }, 1215 | "vctrs": { 1216 | "Package": "vctrs", 1217 | "Version": "0.6.5", 1218 | "Source": "Repository", 1219 | "Repository": "RSPM", 1220 | "Requirements": [ 1221 | "R", 1222 | "cli", 1223 | "glue", 1224 | "lifecycle", 1225 | "rlang" 1226 | ], 1227 | "Hash": "c03fa420630029418f7e6da3667aac4a" 1228 | }, 1229 | "viridisLite": { 1230 | "Package": "viridisLite", 1231 | "Version": "0.4.2", 1232 | "Source": "Repository", 1233 | "Repository": "RSPM", 1234 | "Requirements": [ 1235 | "R" 1236 | ], 1237 | "Hash": "c826c7c4241b6fc89ff55aaea3fa7491" 1238 | }, 1239 | "vroom": { 1240 | "Package": "vroom", 1241 | "Version": "1.6.5", 1242 | "Source": "Repository", 1243 | "Repository": "RSPM", 1244 | "Requirements": [ 1245 | "R", 1246 | "bit64", 1247 | "cli", 1248 | "cpp11", 1249 | "crayon", 1250 | "glue", 1251 | "hms", 1252 | "lifecycle", 1253 | "methods", 1254 | "progress", 1255 | "rlang", 1256 | "stats", 1257 | "tibble", 1258 | "tidyselect", 1259 | "tzdb", 1260 | "vctrs", 1261 | "withr" 1262 | ], 1263 | "Hash": "390f9315bc0025be03012054103d227c" 1264 | }, 1265 | "withr": { 1266 | "Package": "withr", 1267 | "Version": "3.0.0", 1268 | "Source": "Repository", 1269 | "Repository": "RSPM", 1270 | "Requirements": [ 1271 | "R", 1272 | "grDevices", 1273 | "graphics" 1274 | ], 1275 | "Hash": "d31b6c62c10dcf11ec530ca6b0dd5d35" 1276 | }, 1277 | "xfun": { 1278 | "Package": "xfun", 1279 | "Version": "0.45", 1280 | "Source": "Repository", 1281 | "Repository": "CRAN", 1282 | "Requirements": [ 1283 | "grDevices", 1284 | "stats", 1285 | "tools" 1286 | ], 1287 | "Hash": "ca59c87fe305b16a9141a5874c3a7889" 1288 | }, 1289 | "xml2": { 1290 | "Package": "xml2", 1291 | "Version": "1.3.6", 1292 | "Source": "Repository", 1293 | "Repository": "CRAN", 1294 | "Requirements": [ 1295 | "R", 1296 | "cli", 1297 | "methods", 1298 | "rlang" 1299 | ], 1300 | "Hash": "1d0336142f4cd25d8d23cd3ba7a8fb61" 1301 | }, 1302 | "yaml": { 1303 | "Package": "yaml", 1304 | "Version": "2.3.8", 1305 | "Source": "Repository", 1306 | "Repository": "RSPM", 1307 | "Hash": "29240487a071f535f5e5d5a323b7afbd" 1308 | } 1309 | } 1310 | } 1311 | -------------------------------------------------------------------------------- /renv/activate.R: -------------------------------------------------------------------------------- 1 | 2 | local({ 3 | 4 | # the requested version of renv 5 | version <- "1.0.7" 6 | attr(version, "sha") <- NULL 7 | 8 | # the project directory 9 | project <- Sys.getenv("RENV_PROJECT") 10 | if (!nzchar(project)) 11 | project <- getwd() 12 | 13 | # use start-up diagnostics if enabled 14 | diagnostics <- Sys.getenv("RENV_STARTUP_DIAGNOSTICS", unset = "FALSE") 15 | if (diagnostics) { 16 | start <- Sys.time() 17 | profile <- tempfile("renv-startup-", fileext = ".Rprof") 18 | utils::Rprof(profile) 19 | on.exit({ 20 | utils::Rprof(NULL) 21 | elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L) 22 | writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed))) 23 | writeLines(sprintf("- Profile: %s", profile)) 24 | print(utils::summaryRprof(profile)) 25 | }, add = TRUE) 26 | } 27 | 28 | # figure out whether the autoloader is enabled 29 | enabled <- local({ 30 | 31 | # first, check config option 32 | override <- getOption("renv.config.autoloader.enabled") 33 | if (!is.null(override)) 34 | return(override) 35 | 36 | # if we're being run in a context where R_LIBS is already set, 37 | # don't load -- presumably we're being run as a sub-process and 38 | # the parent process has already set up library paths for us 39 | rcmd <- Sys.getenv("R_CMD", unset = NA) 40 | rlibs <- Sys.getenv("R_LIBS", unset = NA) 41 | if (!is.na(rlibs) && !is.na(rcmd)) 42 | return(FALSE) 43 | 44 | # next, check environment variables 45 | # TODO: prefer using the configuration one in the future 46 | envvars <- c( 47 | "RENV_CONFIG_AUTOLOADER_ENABLED", 48 | "RENV_AUTOLOADER_ENABLED", 49 | "RENV_ACTIVATE_PROJECT" 50 | ) 51 | 52 | for (envvar in envvars) { 53 | envval <- Sys.getenv(envvar, unset = NA) 54 | if (!is.na(envval)) 55 | return(tolower(envval) %in% c("true", "t", "1")) 56 | } 57 | 58 | # enable by default 59 | TRUE 60 | 61 | }) 62 | 63 | # bail if we're not enabled 64 | if (!enabled) { 65 | 66 | # if we're not enabled, we might still need to manually load 67 | # the user profile here 68 | profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") 69 | if (file.exists(profile)) { 70 | cfg <- Sys.getenv("RENV_CONFIG_USER_PROFILE", unset = "TRUE") 71 | if (tolower(cfg) %in% c("true", "t", "1")) 72 | sys.source(profile, envir = globalenv()) 73 | } 74 | 75 | return(FALSE) 76 | 77 | } 78 | 79 | # avoid recursion 80 | if (identical(getOption("renv.autoloader.running"), TRUE)) { 81 | warning("ignoring recursive attempt to run renv autoloader") 82 | return(invisible(TRUE)) 83 | } 84 | 85 | # signal that we're loading renv during R startup 86 | options(renv.autoloader.running = TRUE) 87 | on.exit(options(renv.autoloader.running = NULL), add = TRUE) 88 | 89 | # signal that we've consented to use renv 90 | options(renv.consent = TRUE) 91 | 92 | # load the 'utils' package eagerly -- this ensures that renv shims, which 93 | # mask 'utils' packages, will come first on the search path 94 | library(utils, lib.loc = .Library) 95 | 96 | # unload renv if it's already been loaded 97 | if ("renv" %in% loadedNamespaces()) 98 | unloadNamespace("renv") 99 | 100 | # load bootstrap tools 101 | `%||%` <- function(x, y) { 102 | if (is.null(x)) y else x 103 | } 104 | 105 | catf <- function(fmt, ..., appendLF = TRUE) { 106 | 107 | quiet <- getOption("renv.bootstrap.quiet", default = FALSE) 108 | if (quiet) 109 | return(invisible()) 110 | 111 | msg <- sprintf(fmt, ...) 112 | cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") 113 | 114 | invisible(msg) 115 | 116 | } 117 | 118 | header <- function(label, 119 | ..., 120 | prefix = "#", 121 | suffix = "-", 122 | n = min(getOption("width"), 78)) 123 | { 124 | label <- sprintf(label, ...) 125 | n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L) 126 | if (n <= 0) 127 | return(paste(prefix, label)) 128 | 129 | tail <- paste(rep.int(suffix, n), collapse = "") 130 | paste0(prefix, " ", label, " ", tail) 131 | 132 | } 133 | 134 | heredoc <- function(text, leave = 0) { 135 | 136 | # remove leading, trailing whitespace 137 | trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) 138 | 139 | # split into lines 140 | lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] 141 | 142 | # compute common indent 143 | indent <- regexpr("[^[:space:]]", lines) 144 | common <- min(setdiff(indent, -1L)) - leave 145 | paste(substring(lines, common), collapse = "\n") 146 | 147 | } 148 | 149 | startswith <- function(string, prefix) { 150 | substring(string, 1, nchar(prefix)) == prefix 151 | } 152 | 153 | bootstrap <- function(version, library) { 154 | 155 | friendly <- renv_bootstrap_version_friendly(version) 156 | section <- header(sprintf("Bootstrapping renv %s", friendly)) 157 | catf(section) 158 | 159 | # attempt to download renv 160 | catf("- Downloading renv ... ", appendLF = FALSE) 161 | withCallingHandlers( 162 | tarball <- renv_bootstrap_download(version), 163 | error = function(err) { 164 | catf("FAILED") 165 | stop("failed to download:\n", conditionMessage(err)) 166 | } 167 | ) 168 | catf("OK") 169 | on.exit(unlink(tarball), add = TRUE) 170 | 171 | # now attempt to install 172 | catf("- Installing renv ... ", appendLF = FALSE) 173 | withCallingHandlers( 174 | status <- renv_bootstrap_install(version, tarball, library), 175 | error = function(err) { 176 | catf("FAILED") 177 | stop("failed to install:\n", conditionMessage(err)) 178 | } 179 | ) 180 | catf("OK") 181 | 182 | # add empty line to break up bootstrapping from normal output 183 | catf("") 184 | 185 | return(invisible()) 186 | } 187 | 188 | renv_bootstrap_tests_running <- function() { 189 | getOption("renv.tests.running", default = FALSE) 190 | } 191 | 192 | renv_bootstrap_repos <- function() { 193 | 194 | # get CRAN repository 195 | cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") 196 | 197 | # check for repos override 198 | repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) 199 | if (!is.na(repos)) { 200 | 201 | # check for RSPM; if set, use a fallback repository for renv 202 | rspm <- Sys.getenv("RSPM", unset = NA) 203 | if (identical(rspm, repos)) 204 | repos <- c(RSPM = rspm, CRAN = cran) 205 | 206 | return(repos) 207 | 208 | } 209 | 210 | # check for lockfile repositories 211 | repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) 212 | if (!inherits(repos, "error") && length(repos)) 213 | return(repos) 214 | 215 | # retrieve current repos 216 | repos <- getOption("repos") 217 | 218 | # ensure @CRAN@ entries are resolved 219 | repos[repos == "@CRAN@"] <- cran 220 | 221 | # add in renv.bootstrap.repos if set 222 | default <- c(FALLBACK = "https://cloud.r-project.org") 223 | extra <- getOption("renv.bootstrap.repos", default = default) 224 | repos <- c(repos, extra) 225 | 226 | # remove duplicates that might've snuck in 227 | dupes <- duplicated(repos) | duplicated(names(repos)) 228 | repos[!dupes] 229 | 230 | } 231 | 232 | renv_bootstrap_repos_lockfile <- function() { 233 | 234 | lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") 235 | if (!file.exists(lockpath)) 236 | return(NULL) 237 | 238 | lockfile <- tryCatch(renv_json_read(lockpath), error = identity) 239 | if (inherits(lockfile, "error")) { 240 | warning(lockfile) 241 | return(NULL) 242 | } 243 | 244 | repos <- lockfile$R$Repositories 245 | if (length(repos) == 0) 246 | return(NULL) 247 | 248 | keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) 249 | vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) 250 | names(vals) <- keys 251 | 252 | return(vals) 253 | 254 | } 255 | 256 | renv_bootstrap_download <- function(version) { 257 | 258 | sha <- attr(version, "sha", exact = TRUE) 259 | 260 | methods <- if (!is.null(sha)) { 261 | 262 | # attempting to bootstrap a development version of renv 263 | c( 264 | function() renv_bootstrap_download_tarball(sha), 265 | function() renv_bootstrap_download_github(sha) 266 | ) 267 | 268 | } else { 269 | 270 | # attempting to bootstrap a release version of renv 271 | c( 272 | function() renv_bootstrap_download_tarball(version), 273 | function() renv_bootstrap_download_cran_latest(version), 274 | function() renv_bootstrap_download_cran_archive(version) 275 | ) 276 | 277 | } 278 | 279 | for (method in methods) { 280 | path <- tryCatch(method(), error = identity) 281 | if (is.character(path) && file.exists(path)) 282 | return(path) 283 | } 284 | 285 | stop("All download methods failed") 286 | 287 | } 288 | 289 | renv_bootstrap_download_impl <- function(url, destfile) { 290 | 291 | mode <- "wb" 292 | 293 | # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 294 | fixup <- 295 | Sys.info()[["sysname"]] == "Windows" && 296 | substring(url, 1L, 5L) == "file:" 297 | 298 | if (fixup) 299 | mode <- "w+b" 300 | 301 | args <- list( 302 | url = url, 303 | destfile = destfile, 304 | mode = mode, 305 | quiet = TRUE 306 | ) 307 | 308 | if ("headers" %in% names(formals(utils::download.file))) 309 | args$headers <- renv_bootstrap_download_custom_headers(url) 310 | 311 | do.call(utils::download.file, args) 312 | 313 | } 314 | 315 | renv_bootstrap_download_custom_headers <- function(url) { 316 | 317 | headers <- getOption("renv.download.headers") 318 | if (is.null(headers)) 319 | return(character()) 320 | 321 | if (!is.function(headers)) 322 | stopf("'renv.download.headers' is not a function") 323 | 324 | headers <- headers(url) 325 | if (length(headers) == 0L) 326 | return(character()) 327 | 328 | if (is.list(headers)) 329 | headers <- unlist(headers, recursive = FALSE, use.names = TRUE) 330 | 331 | ok <- 332 | is.character(headers) && 333 | is.character(names(headers)) && 334 | all(nzchar(names(headers))) 335 | 336 | if (!ok) 337 | stop("invocation of 'renv.download.headers' did not return a named character vector") 338 | 339 | headers 340 | 341 | } 342 | 343 | renv_bootstrap_download_cran_latest <- function(version) { 344 | 345 | spec <- renv_bootstrap_download_cran_latest_find(version) 346 | type <- spec$type 347 | repos <- spec$repos 348 | 349 | baseurl <- utils::contrib.url(repos = repos, type = type) 350 | ext <- if (identical(type, "source")) 351 | ".tar.gz" 352 | else if (Sys.info()[["sysname"]] == "Windows") 353 | ".zip" 354 | else 355 | ".tgz" 356 | name <- sprintf("renv_%s%s", version, ext) 357 | url <- paste(baseurl, name, sep = "/") 358 | 359 | destfile <- file.path(tempdir(), name) 360 | status <- tryCatch( 361 | renv_bootstrap_download_impl(url, destfile), 362 | condition = identity 363 | ) 364 | 365 | if (inherits(status, "condition")) 366 | return(FALSE) 367 | 368 | # report success and return 369 | destfile 370 | 371 | } 372 | 373 | renv_bootstrap_download_cran_latest_find <- function(version) { 374 | 375 | # check whether binaries are supported on this system 376 | binary <- 377 | getOption("renv.bootstrap.binary", default = TRUE) && 378 | !identical(.Platform$pkgType, "source") && 379 | !identical(getOption("pkgType"), "source") && 380 | Sys.info()[["sysname"]] %in% c("Darwin", "Windows") 381 | 382 | types <- c(if (binary) "binary", "source") 383 | 384 | # iterate over types + repositories 385 | for (type in types) { 386 | for (repos in renv_bootstrap_repos()) { 387 | 388 | # retrieve package database 389 | db <- tryCatch( 390 | as.data.frame( 391 | utils::available.packages(type = type, repos = repos), 392 | stringsAsFactors = FALSE 393 | ), 394 | error = identity 395 | ) 396 | 397 | if (inherits(db, "error")) 398 | next 399 | 400 | # check for compatible entry 401 | entry <- db[db$Package %in% "renv" & db$Version %in% version, ] 402 | if (nrow(entry) == 0) 403 | next 404 | 405 | # found it; return spec to caller 406 | spec <- list(entry = entry, type = type, repos = repos) 407 | return(spec) 408 | 409 | } 410 | } 411 | 412 | # if we got here, we failed to find renv 413 | fmt <- "renv %s is not available from your declared package repositories" 414 | stop(sprintf(fmt, version)) 415 | 416 | } 417 | 418 | renv_bootstrap_download_cran_archive <- function(version) { 419 | 420 | name <- sprintf("renv_%s.tar.gz", version) 421 | repos <- renv_bootstrap_repos() 422 | urls <- file.path(repos, "src/contrib/Archive/renv", name) 423 | destfile <- file.path(tempdir(), name) 424 | 425 | for (url in urls) { 426 | 427 | status <- tryCatch( 428 | renv_bootstrap_download_impl(url, destfile), 429 | condition = identity 430 | ) 431 | 432 | if (identical(status, 0L)) 433 | return(destfile) 434 | 435 | } 436 | 437 | return(FALSE) 438 | 439 | } 440 | 441 | renv_bootstrap_download_tarball <- function(version) { 442 | 443 | # if the user has provided the path to a tarball via 444 | # an environment variable, then use it 445 | tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) 446 | if (is.na(tarball)) 447 | return() 448 | 449 | # allow directories 450 | if (dir.exists(tarball)) { 451 | name <- sprintf("renv_%s.tar.gz", version) 452 | tarball <- file.path(tarball, name) 453 | } 454 | 455 | # bail if it doesn't exist 456 | if (!file.exists(tarball)) { 457 | 458 | # let the user know we weren't able to honour their request 459 | fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." 460 | msg <- sprintf(fmt, tarball) 461 | warning(msg) 462 | 463 | # bail 464 | return() 465 | 466 | } 467 | 468 | catf("- Using local tarball '%s'.", tarball) 469 | tarball 470 | 471 | } 472 | 473 | renv_bootstrap_download_github <- function(version) { 474 | 475 | enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") 476 | if (!identical(enabled, "TRUE")) 477 | return(FALSE) 478 | 479 | # prepare download options 480 | pat <- Sys.getenv("GITHUB_PAT") 481 | if (nzchar(Sys.which("curl")) && nzchar(pat)) { 482 | fmt <- "--location --fail --header \"Authorization: token %s\"" 483 | extra <- sprintf(fmt, pat) 484 | saved <- options("download.file.method", "download.file.extra") 485 | options(download.file.method = "curl", download.file.extra = extra) 486 | on.exit(do.call(base::options, saved), add = TRUE) 487 | } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { 488 | fmt <- "--header=\"Authorization: token %s\"" 489 | extra <- sprintf(fmt, pat) 490 | saved <- options("download.file.method", "download.file.extra") 491 | options(download.file.method = "wget", download.file.extra = extra) 492 | on.exit(do.call(base::options, saved), add = TRUE) 493 | } 494 | 495 | url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) 496 | name <- sprintf("renv_%s.tar.gz", version) 497 | destfile <- file.path(tempdir(), name) 498 | 499 | status <- tryCatch( 500 | renv_bootstrap_download_impl(url, destfile), 501 | condition = identity 502 | ) 503 | 504 | if (!identical(status, 0L)) 505 | return(FALSE) 506 | 507 | renv_bootstrap_download_augment(destfile) 508 | 509 | return(destfile) 510 | 511 | } 512 | 513 | # Add Sha to DESCRIPTION. This is stop gap until #890, after which we 514 | # can use renv::install() to fully capture metadata. 515 | renv_bootstrap_download_augment <- function(destfile) { 516 | sha <- renv_bootstrap_git_extract_sha1_tar(destfile) 517 | if (is.null(sha)) { 518 | return() 519 | } 520 | 521 | # Untar 522 | tempdir <- tempfile("renv-github-") 523 | on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) 524 | untar(destfile, exdir = tempdir) 525 | pkgdir <- dir(tempdir, full.names = TRUE)[[1]] 526 | 527 | # Modify description 528 | desc_path <- file.path(pkgdir, "DESCRIPTION") 529 | desc_lines <- readLines(desc_path) 530 | remotes_fields <- c( 531 | "RemoteType: github", 532 | "RemoteHost: api.github.com", 533 | "RemoteRepo: renv", 534 | "RemoteUsername: rstudio", 535 | "RemotePkgRef: rstudio/renv", 536 | paste("RemoteRef: ", sha), 537 | paste("RemoteSha: ", sha) 538 | ) 539 | writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path) 540 | 541 | # Re-tar 542 | local({ 543 | old <- setwd(tempdir) 544 | on.exit(setwd(old), add = TRUE) 545 | 546 | tar(destfile, compression = "gzip") 547 | }) 548 | invisible() 549 | } 550 | 551 | # Extract the commit hash from a git archive. Git archives include the SHA1 552 | # hash as the comment field of the tarball pax extended header 553 | # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html) 554 | # For GitHub archives this should be the first header after the default one 555 | # (512 byte) header. 556 | renv_bootstrap_git_extract_sha1_tar <- function(bundle) { 557 | 558 | # open the bundle for reading 559 | # We use gzcon for everything because (from ?gzcon) 560 | # > Reading from a connection which does not supply a 'gzip' magic 561 | # > header is equivalent to reading from the original connection 562 | conn <- gzcon(file(bundle, open = "rb", raw = TRUE)) 563 | on.exit(close(conn)) 564 | 565 | # The default pax header is 512 bytes long and the first pax extended header 566 | # with the comment should be 51 bytes long 567 | # `52 comment=` (11 chars) + 40 byte SHA1 hash 568 | len <- 0x200 + 0x33 569 | res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len]) 570 | 571 | if (grepl("^52 comment=", res)) { 572 | sub("52 comment=", "", res) 573 | } else { 574 | NULL 575 | } 576 | } 577 | 578 | renv_bootstrap_install <- function(version, tarball, library) { 579 | 580 | # attempt to install it into project library 581 | dir.create(library, showWarnings = FALSE, recursive = TRUE) 582 | output <- renv_bootstrap_install_impl(library, tarball) 583 | 584 | # check for successful install 585 | status <- attr(output, "status") 586 | if (is.null(status) || identical(status, 0L)) 587 | return(status) 588 | 589 | # an error occurred; report it 590 | header <- "installation of renv failed" 591 | lines <- paste(rep.int("=", nchar(header)), collapse = "") 592 | text <- paste(c(header, lines, output), collapse = "\n") 593 | stop(text) 594 | 595 | } 596 | 597 | renv_bootstrap_install_impl <- function(library, tarball) { 598 | 599 | # invoke using system2 so we can capture and report output 600 | bin <- R.home("bin") 601 | exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" 602 | R <- file.path(bin, exe) 603 | 604 | args <- c( 605 | "--vanilla", "CMD", "INSTALL", "--no-multiarch", 606 | "-l", shQuote(path.expand(library)), 607 | shQuote(path.expand(tarball)) 608 | ) 609 | 610 | system2(R, args, stdout = TRUE, stderr = TRUE) 611 | 612 | } 613 | 614 | renv_bootstrap_platform_prefix <- function() { 615 | 616 | # construct version prefix 617 | version <- paste(R.version$major, R.version$minor, sep = ".") 618 | prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") 619 | 620 | # include SVN revision for development versions of R 621 | # (to avoid sharing platform-specific artefacts with released versions of R) 622 | devel <- 623 | identical(R.version[["status"]], "Under development (unstable)") || 624 | identical(R.version[["nickname"]], "Unsuffered Consequences") 625 | 626 | if (devel) 627 | prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") 628 | 629 | # build list of path components 630 | components <- c(prefix, R.version$platform) 631 | 632 | # include prefix if provided by user 633 | prefix <- renv_bootstrap_platform_prefix_impl() 634 | if (!is.na(prefix) && nzchar(prefix)) 635 | components <- c(prefix, components) 636 | 637 | # build prefix 638 | paste(components, collapse = "/") 639 | 640 | } 641 | 642 | renv_bootstrap_platform_prefix_impl <- function() { 643 | 644 | # if an explicit prefix has been supplied, use it 645 | prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) 646 | if (!is.na(prefix)) 647 | return(prefix) 648 | 649 | # if the user has requested an automatic prefix, generate it 650 | auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) 651 | if (is.na(auto) && getRversion() >= "4.4.0") 652 | auto <- "TRUE" 653 | 654 | if (auto %in% c("TRUE", "True", "true", "1")) 655 | return(renv_bootstrap_platform_prefix_auto()) 656 | 657 | # empty string on failure 658 | "" 659 | 660 | } 661 | 662 | renv_bootstrap_platform_prefix_auto <- function() { 663 | 664 | prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) 665 | if (inherits(prefix, "error") || prefix %in% "unknown") { 666 | 667 | msg <- paste( 668 | "failed to infer current operating system", 669 | "please file a bug report at https://github.com/rstudio/renv/issues", 670 | sep = "; " 671 | ) 672 | 673 | warning(msg) 674 | 675 | } 676 | 677 | prefix 678 | 679 | } 680 | 681 | renv_bootstrap_platform_os <- function() { 682 | 683 | sysinfo <- Sys.info() 684 | sysname <- sysinfo[["sysname"]] 685 | 686 | # handle Windows + macOS up front 687 | if (sysname == "Windows") 688 | return("windows") 689 | else if (sysname == "Darwin") 690 | return("macos") 691 | 692 | # check for os-release files 693 | for (file in c("/etc/os-release", "/usr/lib/os-release")) 694 | if (file.exists(file)) 695 | return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) 696 | 697 | # check for redhat-release files 698 | if (file.exists("/etc/redhat-release")) 699 | return(renv_bootstrap_platform_os_via_redhat_release()) 700 | 701 | "unknown" 702 | 703 | } 704 | 705 | renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { 706 | 707 | # read /etc/os-release 708 | release <- utils::read.table( 709 | file = file, 710 | sep = "=", 711 | quote = c("\"", "'"), 712 | col.names = c("Key", "Value"), 713 | comment.char = "#", 714 | stringsAsFactors = FALSE 715 | ) 716 | 717 | vars <- as.list(release$Value) 718 | names(vars) <- release$Key 719 | 720 | # get os name 721 | os <- tolower(sysinfo[["sysname"]]) 722 | 723 | # read id 724 | id <- "unknown" 725 | for (field in c("ID", "ID_LIKE")) { 726 | if (field %in% names(vars) && nzchar(vars[[field]])) { 727 | id <- vars[[field]] 728 | break 729 | } 730 | } 731 | 732 | # read version 733 | version <- "unknown" 734 | for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { 735 | if (field %in% names(vars) && nzchar(vars[[field]])) { 736 | version <- vars[[field]] 737 | break 738 | } 739 | } 740 | 741 | # join together 742 | paste(c(os, id, version), collapse = "-") 743 | 744 | } 745 | 746 | renv_bootstrap_platform_os_via_redhat_release <- function() { 747 | 748 | # read /etc/redhat-release 749 | contents <- readLines("/etc/redhat-release", warn = FALSE) 750 | 751 | # infer id 752 | id <- if (grepl("centos", contents, ignore.case = TRUE)) 753 | "centos" 754 | else if (grepl("redhat", contents, ignore.case = TRUE)) 755 | "redhat" 756 | else 757 | "unknown" 758 | 759 | # try to find a version component (very hacky) 760 | version <- "unknown" 761 | 762 | parts <- strsplit(contents, "[[:space:]]")[[1L]] 763 | for (part in parts) { 764 | 765 | nv <- tryCatch(numeric_version(part), error = identity) 766 | if (inherits(nv, "error")) 767 | next 768 | 769 | version <- nv[1, 1] 770 | break 771 | 772 | } 773 | 774 | paste(c("linux", id, version), collapse = "-") 775 | 776 | } 777 | 778 | renv_bootstrap_library_root_name <- function(project) { 779 | 780 | # use project name as-is if requested 781 | asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") 782 | if (asis) 783 | return(basename(project)) 784 | 785 | # otherwise, disambiguate based on project's path 786 | id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) 787 | paste(basename(project), id, sep = "-") 788 | 789 | } 790 | 791 | renv_bootstrap_library_root <- function(project) { 792 | 793 | prefix <- renv_bootstrap_profile_prefix() 794 | 795 | path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) 796 | if (!is.na(path)) 797 | return(paste(c(path, prefix), collapse = "/")) 798 | 799 | path <- renv_bootstrap_library_root_impl(project) 800 | if (!is.null(path)) { 801 | name <- renv_bootstrap_library_root_name(project) 802 | return(paste(c(path, prefix, name), collapse = "/")) 803 | } 804 | 805 | renv_bootstrap_paths_renv("library", project = project) 806 | 807 | } 808 | 809 | renv_bootstrap_library_root_impl <- function(project) { 810 | 811 | root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) 812 | if (!is.na(root)) 813 | return(root) 814 | 815 | type <- renv_bootstrap_project_type(project) 816 | if (identical(type, "package")) { 817 | userdir <- renv_bootstrap_user_dir() 818 | return(file.path(userdir, "library")) 819 | } 820 | 821 | } 822 | 823 | renv_bootstrap_validate_version <- function(version, description = NULL) { 824 | 825 | # resolve description file 826 | # 827 | # avoid passing lib.loc to `packageDescription()` below, since R will 828 | # use the loaded version of the package by default anyhow. note that 829 | # this function should only be called after 'renv' is loaded 830 | # https://github.com/rstudio/renv/issues/1625 831 | description <- description %||% packageDescription("renv") 832 | 833 | # check whether requested version 'version' matches loaded version of renv 834 | sha <- attr(version, "sha", exact = TRUE) 835 | valid <- if (!is.null(sha)) 836 | renv_bootstrap_validate_version_dev(sha, description) 837 | else 838 | renv_bootstrap_validate_version_release(version, description) 839 | 840 | if (valid) 841 | return(TRUE) 842 | 843 | # the loaded version of renv doesn't match the requested version; 844 | # give the user instructions on how to proceed 845 | dev <- identical(description[["RemoteType"]], "github") 846 | remote <- if (dev) 847 | paste("rstudio/renv", description[["RemoteSha"]], sep = "@") 848 | else 849 | paste("renv", description[["Version"]], sep = "@") 850 | 851 | # display both loaded version + sha if available 852 | friendly <- renv_bootstrap_version_friendly( 853 | version = description[["Version"]], 854 | sha = if (dev) description[["RemoteSha"]] 855 | ) 856 | 857 | fmt <- heredoc(" 858 | renv %1$s was loaded from project library, but this project is configured to use renv %2$s. 859 | - Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile. 860 | - Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library. 861 | ") 862 | catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) 863 | 864 | FALSE 865 | 866 | } 867 | 868 | renv_bootstrap_validate_version_dev <- function(version, description) { 869 | expected <- description[["RemoteSha"]] 870 | is.character(expected) && startswith(expected, version) 871 | } 872 | 873 | renv_bootstrap_validate_version_release <- function(version, description) { 874 | expected <- description[["Version"]] 875 | is.character(expected) && identical(expected, version) 876 | } 877 | 878 | renv_bootstrap_hash_text <- function(text) { 879 | 880 | hashfile <- tempfile("renv-hash-") 881 | on.exit(unlink(hashfile), add = TRUE) 882 | 883 | writeLines(text, con = hashfile) 884 | tools::md5sum(hashfile) 885 | 886 | } 887 | 888 | renv_bootstrap_load <- function(project, libpath, version) { 889 | 890 | # try to load renv from the project library 891 | if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) 892 | return(FALSE) 893 | 894 | # warn if the version of renv loaded does not match 895 | renv_bootstrap_validate_version(version) 896 | 897 | # execute renv load hooks, if any 898 | hooks <- getHook("renv::autoload") 899 | for (hook in hooks) 900 | if (is.function(hook)) 901 | tryCatch(hook(), error = warnify) 902 | 903 | # load the project 904 | renv::load(project) 905 | 906 | TRUE 907 | 908 | } 909 | 910 | renv_bootstrap_profile_load <- function(project) { 911 | 912 | # if RENV_PROFILE is already set, just use that 913 | profile <- Sys.getenv("RENV_PROFILE", unset = NA) 914 | if (!is.na(profile) && nzchar(profile)) 915 | return(profile) 916 | 917 | # check for a profile file (nothing to do if it doesn't exist) 918 | path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) 919 | if (!file.exists(path)) 920 | return(NULL) 921 | 922 | # read the profile, and set it if it exists 923 | contents <- readLines(path, warn = FALSE) 924 | if (length(contents) == 0L) 925 | return(NULL) 926 | 927 | # set RENV_PROFILE 928 | profile <- contents[[1L]] 929 | if (!profile %in% c("", "default")) 930 | Sys.setenv(RENV_PROFILE = profile) 931 | 932 | profile 933 | 934 | } 935 | 936 | renv_bootstrap_profile_prefix <- function() { 937 | profile <- renv_bootstrap_profile_get() 938 | if (!is.null(profile)) 939 | return(file.path("profiles", profile, "renv")) 940 | } 941 | 942 | renv_bootstrap_profile_get <- function() { 943 | profile <- Sys.getenv("RENV_PROFILE", unset = "") 944 | renv_bootstrap_profile_normalize(profile) 945 | } 946 | 947 | renv_bootstrap_profile_set <- function(profile) { 948 | profile <- renv_bootstrap_profile_normalize(profile) 949 | if (is.null(profile)) 950 | Sys.unsetenv("RENV_PROFILE") 951 | else 952 | Sys.setenv(RENV_PROFILE = profile) 953 | } 954 | 955 | renv_bootstrap_profile_normalize <- function(profile) { 956 | 957 | if (is.null(profile) || profile %in% c("", "default")) 958 | return(NULL) 959 | 960 | profile 961 | 962 | } 963 | 964 | renv_bootstrap_path_absolute <- function(path) { 965 | 966 | substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( 967 | substr(path, 1L, 1L) %in% c(letters, LETTERS) && 968 | substr(path, 2L, 3L) %in% c(":/", ":\\") 969 | ) 970 | 971 | } 972 | 973 | renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { 974 | renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") 975 | root <- if (renv_bootstrap_path_absolute(renv)) NULL else project 976 | prefix <- if (profile) renv_bootstrap_profile_prefix() 977 | components <- c(root, renv, prefix, ...) 978 | paste(components, collapse = "/") 979 | } 980 | 981 | renv_bootstrap_project_type <- function(path) { 982 | 983 | descpath <- file.path(path, "DESCRIPTION") 984 | if (!file.exists(descpath)) 985 | return("unknown") 986 | 987 | desc <- tryCatch( 988 | read.dcf(descpath, all = TRUE), 989 | error = identity 990 | ) 991 | 992 | if (inherits(desc, "error")) 993 | return("unknown") 994 | 995 | type <- desc$Type 996 | if (!is.null(type)) 997 | return(tolower(type)) 998 | 999 | package <- desc$Package 1000 | if (!is.null(package)) 1001 | return("package") 1002 | 1003 | "unknown" 1004 | 1005 | } 1006 | 1007 | renv_bootstrap_user_dir <- function() { 1008 | dir <- renv_bootstrap_user_dir_impl() 1009 | path.expand(chartr("\\", "/", dir)) 1010 | } 1011 | 1012 | renv_bootstrap_user_dir_impl <- function() { 1013 | 1014 | # use local override if set 1015 | override <- getOption("renv.userdir.override") 1016 | if (!is.null(override)) 1017 | return(override) 1018 | 1019 | # use R_user_dir if available 1020 | tools <- asNamespace("tools") 1021 | if (is.function(tools$R_user_dir)) 1022 | return(tools$R_user_dir("renv", "cache")) 1023 | 1024 | # try using our own backfill for older versions of R 1025 | envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") 1026 | for (envvar in envvars) { 1027 | root <- Sys.getenv(envvar, unset = NA) 1028 | if (!is.na(root)) 1029 | return(file.path(root, "R/renv")) 1030 | } 1031 | 1032 | # use platform-specific default fallbacks 1033 | if (Sys.info()[["sysname"]] == "Windows") 1034 | file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") 1035 | else if (Sys.info()[["sysname"]] == "Darwin") 1036 | "~/Library/Caches/org.R-project.R/R/renv" 1037 | else 1038 | "~/.cache/R/renv" 1039 | 1040 | } 1041 | 1042 | renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) { 1043 | sha <- sha %||% attr(version, "sha", exact = TRUE) 1044 | parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L))) 1045 | paste(parts, collapse = "") 1046 | } 1047 | 1048 | renv_bootstrap_exec <- function(project, libpath, version) { 1049 | if (!renv_bootstrap_load(project, libpath, version)) 1050 | renv_bootstrap_run(version, libpath) 1051 | } 1052 | 1053 | renv_bootstrap_run <- function(version, libpath) { 1054 | 1055 | # perform bootstrap 1056 | bootstrap(version, libpath) 1057 | 1058 | # exit early if we're just testing bootstrap 1059 | if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) 1060 | return(TRUE) 1061 | 1062 | # try again to load 1063 | if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { 1064 | return(renv::load(project = getwd())) 1065 | } 1066 | 1067 | # failed to download or load renv; warn the user 1068 | msg <- c( 1069 | "Failed to find an renv installation: the project will not be loaded.", 1070 | "Use `renv::activate()` to re-initialize the project." 1071 | ) 1072 | 1073 | warning(paste(msg, collapse = "\n"), call. = FALSE) 1074 | 1075 | } 1076 | 1077 | renv_json_read <- function(file = NULL, text = NULL) { 1078 | 1079 | jlerr <- NULL 1080 | 1081 | # if jsonlite is loaded, use that instead 1082 | if ("jsonlite" %in% loadedNamespaces()) { 1083 | 1084 | json <- tryCatch(renv_json_read_jsonlite(file, text), error = identity) 1085 | if (!inherits(json, "error")) 1086 | return(json) 1087 | 1088 | jlerr <- json 1089 | 1090 | } 1091 | 1092 | # otherwise, fall back to the default JSON reader 1093 | json <- tryCatch(renv_json_read_default(file, text), error = identity) 1094 | if (!inherits(json, "error")) 1095 | return(json) 1096 | 1097 | # report an error 1098 | if (!is.null(jlerr)) 1099 | stop(jlerr) 1100 | else 1101 | stop(json) 1102 | 1103 | } 1104 | 1105 | renv_json_read_jsonlite <- function(file = NULL, text = NULL) { 1106 | text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") 1107 | jsonlite::fromJSON(txt = text, simplifyVector = FALSE) 1108 | } 1109 | 1110 | renv_json_read_default <- function(file = NULL, text = NULL) { 1111 | 1112 | # find strings in the JSON 1113 | text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") 1114 | pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' 1115 | locs <- gregexpr(pattern, text, perl = TRUE)[[1]] 1116 | 1117 | # if any are found, replace them with placeholders 1118 | replaced <- text 1119 | strings <- character() 1120 | replacements <- character() 1121 | 1122 | if (!identical(c(locs), -1L)) { 1123 | 1124 | # get the string values 1125 | starts <- locs 1126 | ends <- locs + attr(locs, "match.length") - 1L 1127 | strings <- substring(text, starts, ends) 1128 | 1129 | # only keep those requiring escaping 1130 | strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) 1131 | 1132 | # compute replacements 1133 | replacements <- sprintf('"\032%i\032"', seq_along(strings)) 1134 | 1135 | # replace the strings 1136 | mapply(function(string, replacement) { 1137 | replaced <<- sub(string, replacement, replaced, fixed = TRUE) 1138 | }, strings, replacements) 1139 | 1140 | } 1141 | 1142 | # transform the JSON into something the R parser understands 1143 | transformed <- replaced 1144 | transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) 1145 | transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) 1146 | transformed <- gsub("[]}]", ")", transformed, perl = TRUE) 1147 | transformed <- gsub(":", "=", transformed, fixed = TRUE) 1148 | text <- paste(transformed, collapse = "\n") 1149 | 1150 | # parse it 1151 | json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] 1152 | 1153 | # construct map between source strings, replaced strings 1154 | map <- as.character(parse(text = strings)) 1155 | names(map) <- as.character(parse(text = replacements)) 1156 | 1157 | # convert to list 1158 | map <- as.list(map) 1159 | 1160 | # remap strings in object 1161 | remapped <- renv_json_read_remap(json, map) 1162 | 1163 | # evaluate 1164 | eval(remapped, envir = baseenv()) 1165 | 1166 | } 1167 | 1168 | renv_json_read_remap <- function(json, map) { 1169 | 1170 | # fix names 1171 | if (!is.null(names(json))) { 1172 | lhs <- match(names(json), names(map), nomatch = 0L) 1173 | rhs <- match(names(map), names(json), nomatch = 0L) 1174 | names(json)[rhs] <- map[lhs] 1175 | } 1176 | 1177 | # fix values 1178 | if (is.character(json)) 1179 | return(map[[json]] %||% json) 1180 | 1181 | # handle true, false, null 1182 | if (is.name(json)) { 1183 | text <- as.character(json) 1184 | if (text == "true") 1185 | return(TRUE) 1186 | else if (text == "false") 1187 | return(FALSE) 1188 | else if (text == "null") 1189 | return(NULL) 1190 | } 1191 | 1192 | # recurse 1193 | if (is.recursive(json)) { 1194 | for (i in seq_along(json)) { 1195 | json[i] <- list(renv_json_read_remap(json[[i]], map)) 1196 | } 1197 | } 1198 | 1199 | json 1200 | 1201 | } 1202 | 1203 | # load the renv profile, if any 1204 | renv_bootstrap_profile_load(project) 1205 | 1206 | # construct path to library root 1207 | root <- renv_bootstrap_library_root(project) 1208 | 1209 | # construct library prefix for platform 1210 | prefix <- renv_bootstrap_platform_prefix() 1211 | 1212 | # construct full libpath 1213 | libpath <- file.path(root, prefix) 1214 | 1215 | # run bootstrap code 1216 | renv_bootstrap_exec(project, libpath, version) 1217 | 1218 | invisible() 1219 | 1220 | }) 1221 | -------------------------------------------------------------------------------- /rmd_files/README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: Writing functions in R 3 | output: rmarkdown::github_document 4 | knit: (function(input, ...) { 5 | rmarkdown::render( 6 | input, 7 | output_dir = "../", 8 | output_file = file.path("../README.md") 9 | ) 10 | }) 11 | --- 12 | 13 | ```{r setup, include=FALSE} 14 | # These variables determine whether or not exercise solutions are included 15 | show_solution <- FALSE # This determines if the solutions are displayed in the readme 16 | purl_solutions <- FALSE # This variable relates to code blocks that are exercise solutions 17 | purl_example_code <- TRUE # This variable relates to code blocks that aren't exercise solutions 18 | knitr::opts_chunk$set( 19 | comment = "#>", 20 | fig.path = "../README_files/" 21 | ) 22 | ``` 23 | 24 | This repository is for the Writing Functions in R course offered by the Data and Analysis R Training Group. 25 | 26 | Knowing how to write your own functions is a great skill to add to your R toolbox. Writing functions can save you time, reduce the risk of errors, and make your code easier to understand. In this course we’ll cover why, when and how to write your own functions, with plenty of examples & exercises to help you get started. 27 | 28 | The session is intended to be accessible to anyone who is familiar with the content of the [Introduction to R](https://github.com/moj-analytical-services/IntroRTraining) training session & has some experience of using R in their work. 29 | 30 | This training session is periodically run in person/over Teams. Alternatively, you can go through this material in your own time - all the notes are available below and you can also find the recording of a previous session [here](https://justiceuk.sharepoint.com/:f:/s/RTrainingGroup/Ev1kwXxGaVNNpLwFg4drakUBNUpZz72DRdcD8PipkU-u9A?e=SQzeJL). See [Remote learning](#remote-learning) for more tips on going through this material in your own time. If you work through the material by yourself please leave feedback about the material [here](https://airtable.com/shr9u2OJB2pW8Y0Af). 31 | 32 | If you have any feedback on the content, please get in touch! 33 | 34 | ## Contents 35 | 36 | * [Pre-material](#pre-material) 37 | * [Remote learning](#remote-learning) 38 | * [Learning outcomes](#learning-outcomes) 39 | * [What is a function?](#what-is-a-function) 40 | * [Why use functions?](#why-use-functions) 41 | * [How to write a function](#how-to-write-a-function) 42 | * [Examples of basic functions](#examples-of-basic-functions) 43 | * ["Real-world" example functions](#real-world-example-functions) 44 | * [When to write a function](#when-to-write-a-function) 45 | * [Best practice](#best-practice) 46 | * [How to organise your code](#how-to-organise-your-code) 47 | * [Writing a package](#writing-a-package) 48 | * [Further reading](#further-reading) 49 | * [Appendix](#appendix) 50 | * [Information for presenters](#information-for-presenters) 51 | 52 | ## Pre-material 53 | 54 | A few days before the session, please make sure that - 55 | 56 | 1. You have access to RStudio on the Analytical Platform 57 | 2. You have requested access to the **alpha-r-training** s3 bucket via the [intro_r slack channel on the ASD 58 | workspace](https://moj.enterprise.slack.com/archives/CGKSJV9HN) 59 | 3. You have followed the steps in the [Configure Git and Github section of the Platform User Guidance](https://user-guidance.analytical-platform.service.justice.gov.uk/github/set-up-github.html) to configure Git and GitHub (this only needs doing once) 60 | 4. You have cloned this repository (instructions are in the Analytical Platform User Guidance [here](https://user-guidance.analytical-platform.service.justice.gov.uk/github/rstudio-git.html#work-with-git-in-rstudio)) 61 | 5. You run the command `renv::restore()` in the console to make sure you have the required packages installed 62 | 63 | If you have any problems with the above please get in touch with the course organisers or ask for help on either the #analytical_platform or #intro_r channel on [ASD slack](https://asdslack.slack.com). 64 | 65 | All the examples in the presentation/README are available in the R script example_code.R. 66 | 67 | ## Remote learning 68 | 69 | Here are a few suggestions if you are going through this material in your own time: 70 | 71 | * Both the README and slides contain the same content so you can use whichever works best for you - the only difference is the exercise solutions are only in the slides 72 | * To open the slides, first clone the repo (see [pre-material](#pre-material)) and then open the file "slides.html" from RStudio by clicking "View in web browser" 73 | * You can find a recording of a previous training session on the R training Microsoft Stream channel [here](https://web.microsoftstream.com/channel/aa3cda5d-99d6-4e9d-ac5e-6548dd55f52a) 74 | * If you need any help, the best place to ask is on either the [#intro_r](https://app.slack.com/client/T1PU1AP6D/CGKSJV9HN) or [#r](https://app.slack.com/client/T1PU1AP6D/C1PUCG719) slack channels on ASD slack. 75 | 76 | If you have any feedback on the material and/or your experience of working through it in your own time, please get in touch with a member of the R training group or leave a review on [Airtable](https://airtable.com/shr9u2OJB2pW8Y0Af). 77 | 78 | 79 | ```{r source_content, child = 'content.Rmd'} 80 | ``` 81 | 82 | ```{r source_content, child = 'appendix.Rmd'} 83 | ``` 84 | 85 | ## Information for presenters 86 | 87 | ### Where stuff is for on the day 88 | * The training slides are in [slides.html](slides.html) (you will need to download these and open them in a browser). 89 | * The course material is also duplicated in the README with some additional examples in the appendix. 90 | * The code from the presentation is available in [example_code.R](example_code.R). 91 | * The answers to the exercises are available in [solutions.R](solutions.R). 92 | * The [functions.R](functions.R) script is used in one example to demonstrate how to organize code. 93 | 94 | ### How to update the course contents 95 | The README, slides, solutions, and example_code are all generated from files in the "rmd_files" folder. 96 | 97 | * The bulk of the content is in [rmd_files/content.Rmd](rmd_files/content.Rmd). 98 | * The appendix (used in the README) is in [rmd_files/appendix.Rmd](rmd_files/appendix.Rmd). 99 | * The README is generated from [rmd_files/README.Rmd](rmd_files/README.Rmd) (this will source the contents of 100 | content.Rmd and appendix.Rmd). 101 | * The slides are generated from [rmd_files/slides.Rmd](rmd_files/slides.Rmd) (this will source the contents of 102 | content.Rmd). 103 | * The [rmd_files/functions.R](rmd_files/functions.R) script is a duplicate of the one in the top directory 104 | and is required for knitting the various files. 105 | * The [rmd_files/render_rmakdown_files.R](rmd_files/render_rmakdown_files.R) script contains four code 106 | chunks. Running them will re-generate all the course material. This file should always be run before 107 | you merge any changes to the `main` branch. 108 | 109 | ### Tips when presenting 110 | * You can press F11 to make the presentation full screen. To go off of full screen you can press F11 again. 111 | 112 | -------------------------------------------------------------------------------- /rmd_files/appendix.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: rmarkdown::github_document 3 | --- 4 | 5 | # Appendix 6 | 7 | ## Table of operators 8 | 9 | This table shows some of the logical operators you are likely to encounter when using R. Note that 10 | operators can't be *evaluated* using `package_name::operator` syntax. To import operators from 11 | a package without using `library()` calls you can define them in your script with 12 | `` `operator` <- package_name::`operator` `` or use the 13 | [import](https://cran.r-project.org/web/packages/import/vignettes/import.html) package e.g. 14 | `import::from("magrittr", "%>%")`. 15 | 16 | | Operator | Definition | 17 | | :------: | :--------- | 18 | | == | Equal to | 19 | | != | Not equal to | 20 | | > | Greater than | 21 | | < | Less than | 22 | | >= | Greater than or equal to | 23 | | <= | Less than or equal to | 24 | | ǀ | Or | 25 | | & | And | 26 | | ! | Not | 27 | | %in% | The subject appears in a population | 28 | | is.na() | The subject is NA | 29 | 30 | ## Additional NSE examples 31 | 32 | Below are more examples of how to handle `dplyr()`'s non-standard evaluation. If you wanted to use the `group_by()` and `summarise()` functions in a user-defined function, then one option is to have variables containing the column names as strings, and including these variables as function arguments. In the function these variables can be enclosed by `!!as.name()` to convert them into names, like so: 33 | 34 | ```{r} 35 | sum_group_alt1 <- function(df, group_cols, sum_col) { 36 | 37 | `!!` <- rlang::`!!` 38 | 39 | df |> 40 | dplyr::group_by(!!as.name(group_cols)) |> 41 | dplyr::summarise(counts = sum(!!as.name(sum_col))) 42 | 43 | } 44 | 45 | prosecutions_grouped <- sum_group_alt1(df = prosecutions, 46 | group_cols = "age_range", 47 | sum_col = "count") 48 | prosecutions_grouped 49 | ``` 50 | 51 | Alternatively, this version of the function means the column names can be input as function arguments directly (rather than needing to enclose them in quote marks to turn them into strings). 52 | 53 | ```{r} 54 | sum_group_alt2 <- function(df, group_cols, sum_col) { 55 | 56 | `!!` <- rlang::`!!` 57 | 58 | df |> 59 | dplyr::group_by(!!rlang::enquo(group_cols)) |> 60 | dplyr::summarise(counts = sum(!!rlang::enquo(sum_col))) 61 | 62 | } 63 | 64 | prosecutions_grouped <- sum_group_alt2(df = prosecutions, 65 | group_cols = age_range, 66 | sum_col = count) 67 | prosecutions_grouped 68 | ``` 69 | 70 | The function below shows an example of how our `sum_group()` function can be modified to accept column names as arguments, using the `{{` operator. Note that you need version 0.4 or later of the rlang package to use the `{{` operator. 71 | 72 | ```{r} 73 | sum_group_alt3 <- function(df, group_cols, sum_col) { 74 | 75 | df |> 76 | dplyr::group_by({{ group_cols }}) |> 77 | dplyr::summarise(counts = sum({{ sum_col }})) 78 | 79 | } 80 | 81 | prosecutions_grouped <- sum_group_alt3(df = prosecutions, 82 | group_cols = age_range, 83 | sum_col = count) 84 | prosecutions_grouped 85 | ``` 86 | 87 | ## Bonus examples 88 | 89 | ### Adding an optional total row 90 | 91 | We can extend the `sum_group()` function by having the option to add a row with the total across all categories. Note that this requires the `janitor` package. 92 | 93 | ```{r, message = FALSE} 94 | sum_group <- function(df, group_cols, sum_col, add_total = FALSE) { 95 | 96 | summary <- df |> 97 | dplyr::group_by_at(group_cols) |> 98 | dplyr::summarise_at(sum_col, sum) 99 | 100 | if (add_total == TRUE) { 101 | summary <- summary |> janitor::adorn_totals("row") 102 | } 103 | 104 | summary 105 | 106 | } 107 | ``` 108 | 109 | ### Extracting a subset of the data 110 | 111 | Sometimes processing data requires manipulating dates and times. For example, if we wanted to extract the prosecutions from the year up to a particular date, we could use a function like: 112 | 113 | ```{r} 114 | # This function extracts the prosecutions from a particular year 115 | extract_year <- function(data, end_date) { 116 | 117 | `%m-%` <- lubridate::`%m-%` 118 | 119 | # Ensure the date is a date-time object 120 | if (is.character(end_date)) { end_date <- lubridate::dmy(end_date) } 121 | 122 | # Find end of quarter dates for the past year 123 | quarters_to_include <- end_date %m-% months(c(0, 3, 6, 9)) 124 | 125 | # Format the dates to years and quarters 126 | years <- lubridate::year(quarters_to_include) 127 | quarters <- quarters(quarters_to_include) 128 | 129 | # Combine into a unique set of year-quarters 130 | yearquarters <- stringr::str_c(years, " ", quarters) 131 | 132 | # Filter data based on these years and quarters 133 | data |> 134 | dplyr::mutate(year_quarter = paste(year, quarter)) |> 135 | dplyr::filter(year_quarter %in% yearquarters) 136 | 137 | data 138 | } 139 | ``` 140 | 141 | ```{r} 142 | prosecutions_extract <- extract_year(prosecutions, "31-Mar-2018") 143 | dplyr::glimpse(prosecutions_extract) 144 | ``` 145 | -------------------------------------------------------------------------------- /rmd_files/content.Rmd: -------------------------------------------------------------------------------- 1 | ## Learning outcomes 2 | 3 | ### By the end of this session you should know: 4 | 5 | * How to write a basic function. 6 | * The circumstances when you might want to consider writing a function. 7 | * Why using functions is beneficial. 8 | * The best practice for writing functions. 9 | * Where to go for more information on some of the topics touched on in this course. 10 | 11 | 12 | ### Before we start 13 | To follow along with the code run during this session and participate in the exercises, open the script "example_code.R" in RStudio. All the code that we'll show in this session is stored in "example_code.R", and you can edit this script to write solutions to the exercises. You may also want to have the course [README](https://github.com/moj-analytical-services/writing_functions_in_r) open as a reference. 14 | 15 | The training repo is set up with a `renv` lock.file that includes all the packages and package 16 | versions you will need for this course. Please make sure you pull the latest version of the `main` 17 | branch and run `renv::restore()` before starting! 18 | 19 | --- 20 | 21 | ### A note on the examples given in this course 22 | During this session we'll show lots of examples of functions. Depending on how experienced you are with using R, some of these examples may introduce new concepts that are not the focus of this course. It is not required that you have prior knowledge of these concepts, as they are included only to demonstrate possible uses for functions when undertaking typical programming tasks in Data & Analysis. One of the purposes of the examples is to provide a resource that can be referred back to in the future. 23 | 24 | 25 | ## What is a function? 26 | 27 | Functions are a way to bundle up bits of code to make them easy to reuse. Base R includes numerous built-in functions and there are thousands more R functions in packages available on CRAN and elsewhere. 28 | 29 | 30 | Here is an example of one of the built-in R functions, `sum()`: 31 | 32 | ```{r, purl=purl_example_code} 33 | x <- c(1, 2, 3, 4, 5) # Create a vector of numbers to sum 34 | sum(x) # Sum the numbers contained in 'x' 35 | ``` 36 | 37 | You can also write your own functions, called "user-defined functions". 38 | 39 | Functions in a package are the same thing as functions you define yourself, they're just stored in a different way. 40 | 41 | ## Why use functions? 42 | 43 | ### Code maintenance 44 | 45 | Generally functions are used to automate common tasks, to avoid copying and pasting the same code multiple times with minor alterations. While writing a function has a small up front cost, you'll reap the benefits when you need to make changes to your code, and your QA'er will also thank you, as they'll only need to check your function works once! 46 | 47 | ### Abstraction 48 | 49 | One of the benefits of functions is they abstract away the details of *how* the code works. To use a function, all you need to understand is *what* the function is designed to do. You'll need to understand how your function works when you're writing it of course, but you won't need to think about it every time you use it. 50 | 51 | ### Code legibility 52 | 53 | You can use functions to make your code better structured and easier to read - done well, this can make your code a lot easier to understand for someone unfamiliar with it, or even yourself a few months down the line. 54 | 55 | 56 | ## How to write a function 57 | 58 | The syntax for creating a function is: 59 | 60 | ```{r, purl=purl_example_code} 61 | # Comment describing what the function does 62 | function_name <- function(arg1, arg2) { 63 | # function body, e.g. 64 | paste(arg1, arg2, "!") 65 | } 66 | ``` 67 | 68 | We use `function()` to create a function and assign it to the object `function_name`. 69 | 70 | A function is made up of three components: 71 | 72 | + Its **arguments** (in this example, `arg1` and `arg2`) - these are variables used inside the function body which we can set each time we call the function. 73 | 74 | + The function **body** (everything between the curly brackets) - this is where we put the code. 75 | 76 | + And the function **environment** (where the function was created) - this determines what variables and other functions it has access to. You can find out more about environments [here](https://adv-r.hadley.nz/environments.html). 77 | 78 | # Examples of basic functions 79 | 80 | ## Example 1: a very basic function 81 | 82 | Here's an example of a very basic user-defined function, called `add_two()`, that takes `x` as an argument: 83 | 84 | ```{r, purl=purl_example_code} 85 | # This function takes the argument 'x', and adds 2 to it 86 | add_two <- function(x) { 87 | 88 | x + 2 89 | 90 | } 91 | ``` 92 | 93 | R will automatically return the value of the last evaluated expression. There is also a `return()` 94 | function. More on where to use this later. 95 | 96 | --- 97 | 98 | Let's try using the function `add_two()`: 99 | 100 | ```{r, purl=purl_example_code} 101 | # Calling the function by itself prints the result to the console 102 | add_two(3) 103 | 104 | # Alternatively the result can be saved as a new variable 105 | result <- add_two(3) 106 | result 107 | ``` 108 | 109 | Note: before you can use a function you need to run the code to create it. 110 | 111 | ## Example 2: multiple inputs 112 | 113 | Functions can accept as many arguments as you like, but can only output one object (if it is necessary to output more than one object, then the desired outputs can be combined together into a list, and the list can be returned). Here's a function that requires two input variables: 114 | 115 | ```{r, purl=purl_example_code} 116 | # This function sums the squares of two numbers 117 | sum_squares <- function(x, y) { 118 | 119 | x^2 + y^2 120 | 121 | } 122 | 123 | sum_squares(3, y = 5) 124 | ``` 125 | 126 | When you call a function, you can specify the arguments by position or name. In this example, the function accepts arguments called `x` and `y`, with the order specified as `x` then `y` in the function definition. Therefore when `sum_squares(3, 5)` is called, the arguments are interpreted as `x = 3` and `y = 5`. Alternatively, if we called `sum_squares(5, 3)` then the arguments would be interpreted as `x = 5` and `y = 3`. 127 | 128 | --- 129 | 130 | For more complicated functions with multiple arguments, specifying the arguments by position becomes more error-prone and harder to understand. For home-made functions you should always provide the names of all arguments (except potentially the first one if it is data). 131 | 132 | ```{r, purl=purl_example_code} 133 | # Good 134 | sum_squares(3, y = 5) 135 | 136 | # Acceptable 137 | sum_squares(y = 5, x = 3) 138 | 139 | # Bad 140 | sum_squares(3, 5) 141 | ``` 142 | 143 | ## Exercises 144 | 145 | Let's start with some simple exercises to get familiar with the syntax of writing 146 | functions. 147 | 148 | ### 1.1 hello_world() 149 | Create a function called `hello_world` which prints "Hello world!" to the 150 | console, and call the function. 151 | 152 | ### 1.2 my_mean() 153 | Create a function called `my_mean` which takes two arguments, `x` and `y`, and 154 | calculates their mean. Call the function to find the mean of 7.5 and 16. 155 | 156 | 157 | --- 158 | 159 | ```{r, include=show_solution, purl=purl_solutions} 160 | # 1.1 hello_world() solution 161 | 162 | hello_world <- function() { 163 | print("Hello world!") 164 | } 165 | 166 | hello_world() 167 | ``` 168 | 169 | ```{r, include=show_solution, purl=purl_solutions} 170 | # 1.2 my_mean() solution 171 | 172 | my_mean <- function(x, y) { 173 | (x + y) / 2 174 | } 175 | 176 | my_mean(7.5, 16) 177 | ``` 178 | 179 | 180 | ## Example 3: conditional statements and early returns 181 | 182 | Functions can return different outputs depending on some condition. In this function the condition is `x < 0`, and the condition evaluates to either `TRUE` or `FALSE`: 183 | 184 | ```{r, purl=purl_example_code} 185 | # This function returns the absolute value of a number 186 | abs_x <- function(x) { 187 | if (x >= 0) { 188 | x 189 | } else { 190 | -x 191 | } 192 | } 193 | 194 | abs_x(-5) 195 | abs_x(4) 196 | ``` 197 | 198 | By default R will always return the last evaluated statement. In this example when `x` is greater than 199 | or equal to zero, the last evaluated statement is `x`. In contrast when `x` is less than zero, the 200 | last evaluated statement is `-x`. 201 | 202 | --- 203 | 204 | Why does this function always return minus x? 205 | ```{r, purl=purl_example_code} 206 | # why does this function always return -x? 207 | abs_x_v2 <- function(x) { 208 | 209 | if (x >= 0) { 210 | x 211 | } 212 | 213 | -x 214 | 215 | } 216 | 217 | abs_x_v2(-5) 218 | abs_x_v2(4) 219 | ``` 220 | 221 | --- 222 | 223 | Sometimes exiting a function early is useful. We can achieve this with an explicit `return()`. As 224 | soon as a `return()` statement is encountered in a function, the function finishes and returns the 225 | variable in the `return()` statement. 226 | 227 | ```{r, purl=purl_example_code} 228 | # We can fix it by using an early return 229 | abs_x_v3 <- function(x) { 230 | 231 | if (x >= 0) { 232 | return(x) 233 | } 234 | 235 | -x 236 | 237 | } 238 | 239 | abs_x_v3(-5) 240 | abs_x_v3(4) 241 | ``` 242 | 243 | 244 | 245 | ## Example 4: functions with side-effects 246 | 247 | A function side-effect can be thought of as any change to the workspace that the function makes other than the object that it returns. This can include printing, plotting a chart, saving a file, or modifying a variable in the wider environment. The side-effect is often the main purpose of the function, and in this case the function doesn't need to return any value. This function has the side-effect of printing a message to the console, depending on the value of the object: 248 | 249 | ```{r, purl=purl_example_code} 250 | # This function lets you know whether a number is odd or even 251 | odd_or_even <- function(x) { 252 | 253 | if ((x %% 2) == 0) { 254 | message("The number is even.") 255 | } else if ((x %% 2) == 1) { 256 | message("The number is odd.") 257 | } 258 | 259 | } 260 | 261 | odd_or_even(x = 4) 262 | ``` 263 | 264 | **Note:** It’s best practice for your function to either return an object or have a side-effect, but not both (with the exception of messages, errors and warnings). 265 | 266 | ## Example 5: errors and warnings 267 | 268 | Sometimes it can be useful to include helpful error messages in functions, e.g. by anticipating the sorts of variables that could be input. What happens if you try to use a non-integer or a string as an argument in the previous example? Try the running the function with the following arguments: 269 | 270 | ```{r, error = TRUE, purl=purl_example_code} 271 | odd_or_even(x = 1.5) 272 | odd_or_even(x = "a") 273 | odd_or_even(x = c(1, 2, 3)) 274 | ``` 275 | 276 | --- 277 | 278 | Here's an adapted version of the function, with some more informative error messages built in using the `stop()` function: 279 | 280 | ```{r, purl=purl_example_code} 281 | # This function lets you know whether a number is odd or even 282 | odd_or_even <- function(x) { 283 | if (length(x) > 1) { 284 | stop("x must have length 1.") 285 | } else if (!is.numeric(x)) { 286 | stop("x must be a number.") 287 | } else if ((x %% 2) == 0) { 288 | print("The number is even.") 289 | } else if ((x %% 2) == 1) { 290 | print("The number is odd.") 291 | } else if((x %% 2) != 0 && (x %% 2) != 1) { 292 | stop("x must be an integer.") 293 | } 294 | 295 | } 296 | ``` 297 | 298 | --- 299 | 300 | Now try passing some incompatible arguments to the function: 301 | 302 | ```{r, error = TRUE, purl=purl_example_code} 303 | odd_or_even(x = 1.5) 304 | odd_or_even(x = "a") 305 | odd_or_even(x = c(1, 2, 3)) 306 | ``` 307 | 308 | `stop()` halts execution of the function and prints an error message to the console. Alternatively you can use `warning()`, which returns a warning but does not stop execution of the function. 309 | 310 | ## Example 6: optional arguments 311 | 312 | Here's an example of how to include optional arguments, where in this case the optional argument is called `y`: 313 | 314 | ```{r, purl=purl_example_code} 315 | # This function either returns the sum of two numbers, or returns the argument if only one is supplied 316 | add_a_number <- function(x, y = NULL) { 317 | 318 | if (!is.null(y)) { 319 | x + y 320 | } else { 321 | x 322 | } 323 | 324 | } 325 | 326 | add_a_number(x = 6) 327 | add_a_number(x = 6, y = 7) 328 | ``` 329 | 330 | --- 331 | 332 | Note that `NULL` and `NA` values, and missing arguments are different and tested for in different ways. 333 | 334 | ```{r, purl=purl_example_code} 335 | # This function demonstrates the difference between NULL, NA and "missing" 336 | return_x <- function(x) { 337 | if (missing(x)) { 338 | message("x is missing") 339 | } 340 | if (is.null(x)) { 341 | message("x is null") 342 | } 343 | if (is.na(x)) { 344 | message("x is NA") 345 | } 346 | x 347 | } 348 | 349 | return_x(5) 350 | ``` 351 | 352 | A message will be returned when the relevant condition is found and then R will attempt to evaluate 353 | `x`. Note this will fail when `x` is `NULL` or missing. 354 | 355 | --- 356 | 357 | ```{r, purl=purl_example_code, error = TRUE} 358 | return_x() 359 | return_x(NULL) 360 | return_x(NA) 361 | ``` 362 | 363 | 364 | ## Example 7: arguments with default values 365 | 366 | Any value can be used as a default value for an argument. For example, we can generalise the `sum_squares()` function by allowing it to sum together two numbers raised to any power, but with a default power of 2: 367 | 368 | ```{r, purl=purl_example_code} 369 | # This function returns the sum of two numbers raised to a particular power (with a default of 2) 370 | sum_powers <- function(x, y, z = 2) { 371 | 372 | x ^ z + y ^ z 373 | 374 | } 375 | 376 | sum_powers(x = 3, y = 5) 377 | sum_powers(x = 3, y = 5, z = 3) 378 | ``` 379 | 380 | ## Exercises 381 | 382 | ### 2.1 fizz_buzz() 383 | Now try using an if else statement inside a function. Create a function called `fizz_buzz()` which takes a number as input and: 384 | 385 | * If the number is divisible by both 3 and 5, returns "fizz buzz" 386 | * If the number is divisible by just 3, returns "fizz" 387 | * If the number is divisible by just 5, returns "buzz" 388 | * Otherwise the number is returned (coerced to character type using `as.character()`) 389 | 390 | Try it out with values 1, 2, 3, 5 & 15. 391 | 392 | --- 393 | 394 | **Hints:** 395 | 396 | * This exercise is very similar to example 4. The structure of an if-else statement is: 397 | ``` 398 | if (condition_1) { 399 | code 400 | } else if (condition_2) { 401 | code 402 | } else { 403 | code 404 | } 405 | ``` 406 | * To test whether a number is divisible by another number, you can use the modulus operator `%%`, which calculates the remainder. E.g. `1 %% 3 == 0` evaluates to `FALSE`. 407 | * To find out more about if statements and conditional execution, see [here](https://adv-r.hadley.nz/control-flow.html) 408 | 409 | --- 410 | 411 | ```{r, include=show_solution, purl=purl_solutions, eval=TRUE} 412 | # 2.1 fizz_buzz() solution 413 | 414 | fizz_buzz <- function(x) { 415 | 416 | if (x %% 3 == 0 && x %% 5 == 0) { 417 | "fizz buzz" 418 | } else if (x %% 3 == 0) { 419 | "fizz" 420 | } else if (x %% 5 == 0) { 421 | "buzz" 422 | } else { 423 | as.character(x) 424 | } 425 | 426 | } 427 | ``` 428 | 429 | ```{r, include=show_solution, purl=purl_solutions, eval=FALSE} 430 | fizz_buzz(1) # "1" 431 | fizz_buzz(2) # "2" 432 | fizz_buzz(3) # "fizz" 433 | fizz_buzz(5) # "buzz" 434 | fizz_buzz(15) # "fizz buzz" 435 | ``` 436 | 437 | --- 438 | 439 | ### 2.2 fizz_buzz_vec() 440 | 441 | Most functions in R are vectorised. This means they can apply an operation 442 | to every element of a vector at the same time. It's best practice to vectorise 443 | your own functions too as this will help you to apply them to data sets and 444 | combine them with other functions. 445 | 446 | Create a new version of the `fizz_buzz()` function called `fizz_buzz_vec` which 447 | instead accepts a vector of numbers. Test it out on a vector of the numbers 1 to 15. 448 | 449 | **Hint:** the function `case_when()` from the Tidyverse package `dplyr` is really useful when you want 450 | to vectorise multiple if-else statements, each with a different desired outcome. Run `?case_when` to bring up 451 | the help file. 452 | 453 | *This exercise is a bit tricky - if you get stuck, you can still complete exercise 2.3.* 454 | 455 | --- 456 | 457 | ```{r, include=show_solution, purl=purl_solutions} 458 | # 2.2 fizz_buzz_vec() solution 459 | 460 | fizz_buzz_vec <- function(x) { 461 | 462 | dplyr::case_when( 463 | x %% 3 == 0 & x %% 5 == 0 ~ "fizz buzz", 464 | x %% 3 == 0 ~ "fizz", 465 | x %% 5 == 0 ~ "buzz", 466 | TRUE ~ as.character(x) 467 | ) 468 | 469 | } 470 | 471 | fizz_buzz_vec(1:15) 472 | ``` 473 | 474 | --- 475 | 476 | ### 2.3 fizz_buzz_custom() 477 | 478 | Create a version of `fizz_buzz()` or `fizz_buzz_vec()` called `fizz_buzz_custom()` or 479 | `fizz_buzz_custom_vec()` where the values for when to say "fizz" and "buzz" can be 480 | changed by setting arguments `fizz` and `buzz`, but the default values are still 481 | 3 and 5. 482 | 483 | Test your new function out, first by checking you get the same results as above 484 | when you don't specify the `fizz` or `buzz` arguments, and second when you set 485 | `buzz = 7` for values 1, 2, 3, 7, 15 and 21. 486 | 487 | --- 488 | 489 | ```{r, include=show_solution, purl=purl_solutions} 490 | # 2.3 fizz_buzz_custom() solution 491 | 492 | fizz_buzz_custom <- function(x, fizz = 3, buzz = 5) { 493 | 494 | if (x %% fizz == 0 & x %% buzz == 0) { 495 | "fizz buzz" 496 | } else if (x %% fizz == 0) { 497 | "fizz" 498 | } else if (x %% buzz == 0) { 499 | "buzz" 500 | } else { 501 | as.character(x) 502 | } 503 | 504 | } 505 | 506 | 507 | fizz_buzz_custom_vec <- function(x, fizz = 3, buzz = 5) { 508 | 509 | dplyr::case_when( 510 | x %% fizz == 0 & x %% buzz == 0 ~ "fizz buzz", 511 | x %% fizz == 0 ~ "fizz", 512 | x %% buzz == 0 ~ "buzz", 513 | TRUE ~ as.character(x) 514 | ) 515 | 516 | } 517 | ``` 518 | 519 | --- 520 | 521 | ```{r, include=show_solution, purl=purl_solutions} 522 | fizz_buzz_custom_vec(1:15) 523 | fizz_buzz_custom_vec(c(1, 2, 3, 7, 15, 21), buzz = 7) 524 | ``` 525 | 526 | ## Example 8: the ellipsis argument 527 | 528 | Sometimes being able to pass an arbitrary number of arguments can be useful, especially when another function is called within a wrapper function. This requires the ellipsis construct, `...`, which is designed to pass a variable number of arguments to a function. Here's an example: 529 | 530 | ```{r, purl=purl_example_code} 531 | # This function produces a plot of x vs y 532 | plot_x_and_y <- function(x, y, ...) { 533 | 534 | plot(x, y, ...) 535 | 536 | } 537 | 538 | x <- 1:10 539 | y <- (1:10) * 2 540 | ``` 541 | 542 | --- 543 | 544 | The function can be called with only the required arguments: 545 | 546 | ```{r, purl=purl_example_code} 547 | plot_x_and_y(x, y) 548 | ``` 549 | 550 | --- 551 | 552 | Or the function can be called with any optional arguments accepted by the plot function: 553 | 554 | ```{r, purl=purl_example_code} 555 | plot_x_and_y(x, y, col='red', type='l') 556 | ``` 557 | 558 | # "Real-world" example functions 559 | 560 | ## "Real-world" example functions 561 | 562 | This section builds on material covered in the [Intro R Training](https://github.com/moj-analytical-services/IntroRTraining) course and makes use of the `dplyr` package, which is a commonly used R package for data manipulation. In the following examples we'll see how user-defined functions can be used to help with cleaning, summarising, and plotting data. The data we'll use is from the Criminal Justice System Statistics quarterly publication: December 2018 (published in May 2019), which can be found [here](https://www.gov.uk/government/statistics/criminal-justice-system-statistics-quarterly-december-2018). 563 | 564 | Over the course of this section we'll be tackling some exercises that fit into a data processing story, so make sure you run the code in "example_code.R" as we go along. 565 | 566 | 567 | ## Packages 568 | 569 | For these examples we will be using a few packages: 570 | 571 | * [`Rs3tools`](https://github.com/moj-analytical-services/Rs3tools) to fetch data from s3. 572 | * `dplyr` is the package we'll use to create summary tables from the data. 573 | * `stringr` provides functions that can be used to manipulate strings. 574 | * `ggplot2` to create charts. 575 | 576 | We will use `package::function()` syntax throughout this course instead of `library()` calls. 577 | This makes it easier to see where functions come from, avoids "function masking" and improves the 578 | reproducibility and reusability of code. This is particularly important within the body of a 579 | function. If a dependency has not been attached to the search list at run time, you will get 580 | a probably very unhelpful error message (or your code might use the wrong function). 581 | 582 | For a similar reason we are using the R native pipe `|>` rather than the `magrittr` one. (If you are using 583 | R < 4.1.0 you will need to replace the native pipe with `%>%` and use `library("magrittr")`.) 584 | 585 | 586 | ## Examples why you should avoid `library()` calls 587 | 588 | Which of the following would you rather have to deal with? A missing function from *somewhere*; a 589 | missing but *known* package; or a missing function from a *known* package? 590 | 591 | ``` 592 | > bar() 593 | Error in bar() : could not find function "bar" 594 | 595 | > foo::bar() 596 | Error in loadNamespace(x) : there is no package called ‘foo’ 597 | 598 | > dplyr::bar() 599 | Error: 'bar' is not an exported object from 'namespace:dplyr' 600 | ``` 601 | 602 | --- 603 | 604 | Even worse, your code might silently give the wrong result if you are relying on the user having 605 | made the "correct" `library()` calls. 606 | 607 | ```{r, purl=purl_example_code} 608 | iris_by_species_1 <- function(species) { 609 | datasets::iris |> filter(iris[[5]] == species) |> dplyr::glimpse() 610 | } 611 | 612 | iris_by_species_2 <- function(species) { 613 | datasets::iris |> dplyr::filter(iris[[5]] == species) |> dplyr::glimpse() 614 | } 615 | 616 | iris_by_species_1("setosa") 617 | iris_by_species_2("setosa") 618 | ``` 619 | 620 | ## Fetching data 621 | 622 | Here we are reading in a copy of the `Prosecutions and Convictions` dataset from s3 and storing the dataframe as a variable called `prosecutions_and_convictions`. In the second step we're filtering the dataset to extract only the prosecutions and saving to another variable, named `prosecutions`. 623 | 624 | ```{r message=F, warning=F, purl=purl_example_code} 625 | prosecutions_and_convictions <- Rs3tools::read_using( 626 | FUN = read.csv, 627 | s3_path = "s3://alpha-r-training/writing-functions-in-r/prosecutions-and-convictions-2018.csv" 628 | ) 629 | 630 | # Filter for Magistrates Court to extract the prosecutions 631 | prosecutions <- prosecutions_and_convictions |> 632 | dplyr::filter(`Court.Type` == "Magistrates Court") 633 | ``` 634 | 635 | --- 636 | 637 | Here's a preview of the data stored in `prosecutions`: 638 | 639 | ```{r, purl=purl_example_code} 640 | dplyr::glimpse(prosecutions) 641 | ``` 642 | 643 | 644 | ## Cleaning data 645 | 646 | After reading in a dataframe it can often be helpful to standardise the column headings. Below is an example of a function that could be used for this purpose. It takes a vector of strings as the argument, ensures all letters in the string vector are lower-case, and makes use of "regular expressions" or "regex" to find and replace all spaces and punctuation marks with an underscore: 647 | 648 | ```{r, purl=purl_example_code} 649 | # This function standardises strings contained in a vector 650 | generalise_names <- function(names) { 651 | 652 | names |> 653 | # Convert any uppercase letters to lowercase 654 | tolower() |> 655 | # Trim any blank spaces at the start or end of each string 656 | stringr::str_trim() |> 657 | # Replace anything that isn't a letter or number with an underscore 658 | stringr::str_replace_all(pattern = "[^A-Za-z0-9]", replacement = "_") |> 659 | # Remove repeated underscores 660 | stringr::str_remove_all(pattern = "(?<=_)_+") |> 661 | # Remove any underscore at the beginning or end of the string 662 | stringr::str_remove_all(pattern = "^_|_$") 663 | 664 | } 665 | ``` 666 | 667 | --- 668 | 669 | Here is a demonstration of how functions such as this can be useful: 670 | 671 | ```{r, purl=purl_example_code} 672 | names <- c("Option 1", " Option (1)", "Option: 1", "option 1", "OPTION - 1") 673 | generalise_names(names) 674 | ``` 675 | 676 | The [`stringr` cheatsheet](https://stringr.tidyverse.org/#cheatsheet) is a great resource for 677 | learning more about regular expressions. 678 | 679 | --- 680 | 681 | ### Exercise 3 682 | 683 | Use the `generalise_names()` function defined above to clean the column headings of the `prosecutions` dataset. Add your solution to the script "example_code.R", underneath the line with the command `generalise_names(names)`. 684 | 685 | **Hint:** use the function `colnames()` to retrieve the column headings of the dataset as a vector. 686 | 687 | --- 688 | 689 | ```{r, include=show_solution, purl=purl_solutions} 690 | # Exercise 3 solution 691 | colnames(prosecutions) <- colnames(prosecutions) |> generalise_names() 692 | dplyr::glimpse(prosecutions) 693 | ``` 694 | --- 695 | 696 | In this dataset, some of the columns contain values with a number along with a category; for example, the `age_group` column contains categories like "01: Juveniles" rather than just "Juveniles". 697 | 698 | ```{r, echo=FALSE, purl=purl_example_code} 699 | dplyr::glimpse(prosecutions[, 1:10]) 700 | ``` 701 | 702 | These numbers might be undesirable, so we can write a function like this to remove them: 703 | 704 | ```{r, purl=purl_example_code} 705 | # This function removes patterns at the start of a string that are: 706 | # 1 or 2 digits followed by any number of colons and/or spaces 707 | 708 | remove_numbering <- function(x) { 709 | stringr::str_remove(x, pattern = "^\\d{1,2}\\s*:*\\s*") 710 | } 711 | ``` 712 | 713 | --- 714 | 715 | Here is a demonstration of what this is doing: 716 | 717 | ```{r, purl=purl_example_code} 718 | 719 | some_strings <- c("01 :foo", "01 foo", "01: foo", "01 : foo", "foo", "bar foo") 720 | remove_numbering(some_strings) 721 | 722 | ``` 723 | 724 | The [`stringr` cheatsheet](https://stringr.tidyverse.org/#cheatsheet) is a great resource for 725 | learning more about regular expressions. 726 | 727 | --- 728 | 729 | Then we can use the `mutate()` function with the `across()` function from `dplyr`, and the `where()` selection helper from `tidyselect`, to apply the `remove_numbering()` function to columns in the `prosecutions` dataframe. The `dplyr::mutate()` function will apply the specified function to all columns where a particular condition is met, and in this case the condition `is.character` requires that the column contains strings. 730 | 731 | ```{r, purl=purl_example_code} 732 | prosecutions <- dplyr::mutate(prosecutions, across(where(is.character), remove_numbering)) 733 | dplyr::glimpse(prosecutions) 734 | ``` 735 | 736 | --- 737 | 738 | For the final stage of data cleaning, we can make missing and unknown values more consistent using a function such as the following: 739 | 740 | ```{r, purl=purl_example_code} 741 | clean_not_known <- function(x, 742 | not_known_phrase = "Not known", 743 | values_to_change = c("n/a", "not known", "unknown", "not stated")) { 744 | 745 | # Replace any missing (NA) values 746 | x <- replace(x, list = is.na(x), values = not_known_phrase) 747 | 748 | # Remove any white space that might cause the strings to not match 749 | x <- stringr::str_trim(x) 750 | 751 | # Replace strings in the data that refer to a missing or unknown value. 752 | dplyr::if_else(tolower(x) %in% values_to_change, true = not_known_phrase, false = x) 753 | 754 | } 755 | ``` 756 | 757 | In this function we've included some default values, so by default any strings that match "n/a", "not known", "unknown", or "not stated" are replaced, and the default replacement value is "Not known". We've used `dplyr::if_else()` as a vectorised form of an if-else statement. It's similar to `dplyr::case_when()` (which we used in exercise 2.2), but can only be used with one condition and two possible outcomes. We've also used the `tolower()` function, which ensures all strings are lower case before searching for the missing/unknown phrases. 758 | 759 | --- 760 | 761 | ```{r, purl=purl_example_code} 762 | prosecutions <- dplyr::mutate( 763 | prosecutions, 764 | dplyr::across( 765 | .cols = tidyselect::where(is.character), 766 | .fns = clean_not_known 767 | ) 768 | ) 769 | 770 | dplyr::glimpse(prosecutions) 771 | ``` 772 | 773 | --- 774 | 775 | ### Exercise 4 776 | 777 | Modify `clean_not_known()` to make replacing missing (NA) values optional. 778 | 779 | 780 | ### Exercise 5 781 | 782 | Write a wrapper function to apply `generalise_names()`, `remove_numbering()`, and `clean_not_known()` to the dataset. 783 | 784 | --- 785 | 786 | ```{r, include=show_solution, purl=purl_solutions} 787 | # Exercise 4 solution 788 | 789 | clean_not_known <- function(x, 790 | not_known_phrase = "Not known", 791 | change_na = TRUE, 792 | values_to_change = c("n/a", "not known", "unknown", "not stated")) { 793 | 794 | # Replace any missing (NA) values 795 | if (change_na) { 796 | x <- replace(x, list = is.na(x), values = not_known_phrase) 797 | } 798 | 799 | # Remove any white space that might cause the strings to not match 800 | x <- stringr::str_trim(x) 801 | 802 | # Replace strings in the data that refer to a missing or unknown value. 803 | dplyr::if_else(tolower(x) %in% values_to_change, true = not_known_phrase, false = x) 804 | 805 | } 806 | ``` 807 | 808 | --- 809 | 810 | ```{r, include=show_solution, purl=purl_solutions} 811 | # Exercise 5 solution 812 | 813 | clean_dataset <- function(data) { 814 | 815 | # Clean the column headings 816 | colnames(data) <- generalise_names(colnames(data)) 817 | 818 | # Remove numeric indices from columns 819 | data <- dplyr::mutate( 820 | data, 821 | dplyr::across( 822 | .cols = tidyselect::where(is.character), 823 | .fns = remove_numbering 824 | ) 825 | ) 826 | 827 | # Make missing/unknown value entries more consistent 828 | dplyr::mutate( 829 | data, 830 | dplyr::across( 831 | .cols = tidyselect::where(is.character), 832 | .fns = clean_not_known 833 | ) 834 | ) 835 | 836 | } 837 | ``` 838 | 839 | ```{r, include=FALSE, purl=purl_example_code} 840 | # Solution to exercise 3 - must run before the next section 841 | colnames(prosecutions) <- colnames(prosecutions) |> generalise_names() 842 | ``` 843 | 844 | 845 | ## Summarising data 846 | 847 | Let's say we wanted to create a summary table showing the number of people prosecuted in different age bands. We could do: 848 | 849 | ```{r, purl=purl_example_code} 850 | prosecutions_grouped <- prosecutions |> 851 | dplyr::group_by(age_range) |> 852 | dplyr::summarise(counts = sum(count)) 853 | ``` 854 | 855 | In the above code we are grouping the `prosecutions` dataframe by the categories in the `age_range` column, then summarising the number of prosecutions in each of those categories by summing the `count` column. 856 | 857 | The resulting dataframe is saved as a variable called `prosecutions_grouped`. 858 | 859 | Notice how the `dplyr` functions `group_by()` and `summarise()` require that the column names are not enclosed in quotation marks, meaning that they are not passed as strings: this behaviour is known as non-standard evaluation, and will be important later. 860 | 861 | --- 862 | 863 | ```{r, purl=purl_example_code} 864 | prosecutions_grouped 865 | ``` 866 | 867 | ## Sidenote: standard vs non-standard evaluation 868 | 869 | In the plot below how does R know to label the x-axis `foo` and the y-axis `bar` we haven't explicitly supplied axis labels? The `plot()` function is using standard evaluation to get the values supplied to the x and y axes but is 870 | also using non-standard evaluation to get the names of the objects passed to the arguments for use as axis labels. 871 | 872 | ```{r, purl=purl_example_code, fig.height = 3} 873 | foo <- 1:10 874 | bar <- 10:1 875 | plot(foo, bar) 876 | ``` 877 | 878 | --- 879 | 880 | What if we wanted to create several different summary tables? We could write a function to avoid writing this out each time. Following the previous examples in this course, you might expect this function to work: 881 | 882 | ```{r, error = TRUE, purl=purl_example_code} 883 | # This function produces a summary table based on a dataset 884 | sum_group <- function(df, group_col, sum_col) { 885 | 886 | df |> 887 | dplyr::group_by(group_col) |> 888 | dplyr::summarise(counts = sum(sum_col)) 889 | 890 | } 891 | ``` 892 | 893 | However trying to use this function results in an error. 894 | 895 | ```{r, error = TRUE, purl=purl_example_code} 896 | prosecutions_grouped <- sum_group(df = prosecutions, group_col = "age_range", sum_col = "count") 897 | ``` 898 | 899 | --- 900 | 901 | This is because of the non-standard evaluation (NSE) mentioned above. The `dplyr` functions don't recognise `group_col` and `sum_col` as column names, because they can't see that these are variables containing the actual column names. While the NSE usually makes the `dplyr` functions more convenient to use, it makes them slightly trickier to use in user-defined functions. 902 | 903 | Fortunately there are methods available to help get around the NSE problem. The function below shows an example of how our `sum_group()` function can be modified to accept column names stored as strings, using the `.data` pronoun with `[[]]`. 904 | 905 | ```{r, purl=purl_example_code} 906 | # This function produces a summary table based on a dataset 907 | sum_group <- function(df, group_col, sum_col) { 908 | 909 | df |> 910 | dplyr::group_by(.data[[group_col]]) |> 911 | dplyr::summarise(counts = sum(.data[[sum_col]])) 912 | 913 | } 914 | ``` 915 | 916 | The way that the tidyverse packages handle NSE has evolved over the past few years, so new methods of addressing this issue may be introduced in the future. For the current recommended approach to working with "tidy evaluation", i.e. a special type of NSE used throughout the tidyverse, please see [this vignette](https://dplyr.tidyverse.org/articles/programming.html). See the appendix for some examples of alternative methods to tackle this problem. 917 | 918 | --- 919 | 920 | ```{r, purl=purl_example_code} 921 | prosecutions_grouped <- sum_group(df = prosecutions, group_col = "age_range", sum_col = "count") 922 | prosecutions_grouped 923 | ``` 924 | 925 | ## Plotting data 926 | 927 | Let's say we want to produce some plots, and want them all to have the same style. We can define the style of the plot in a function, then we only have to change the styling in one place if it needs changing. This function plots a breakdown of the number of prosecutions over time, with a default breakdown option of `"offence_type"`, and the plot is a line chart with `ggplot2`'s grey theme: 928 | 929 | ```{r, purl=purl_example_code} 930 | # This function produces a plot of the number of prosecutions over time 931 | plot_prosecutions <- function(df, breakdown = "offence_type") { 932 | 933 | df_grouped <- df |> 934 | dplyr::group_by(.data[[breakdown]], year) |> 935 | dplyr::summarise(counts = sum(count), .groups = "keep") 936 | 937 | df_grouped |> 938 | ggplot2::ggplot( 939 | ggplot2::aes(x = .data$year, 940 | y = .data$counts, 941 | group = .data[[breakdown]], 942 | col = .data[[breakdown]]) 943 | ) + 944 | ggplot2::geom_line() + 945 | ggplot2::scale_x_continuous(breaks = 0:2100) + 946 | ggplot2::theme_grey() 947 | } 948 | ``` 949 | 950 | --- 951 | 952 | ```{r fig.width=10, purl=purl_example_code} 953 | # Call function 954 | plot_prosecutions(prosecutions, breakdown = "offence_type") 955 | ``` 956 | 957 | --- 958 | 959 | ### Exercise 6 960 | 961 | Modify the `plot_prosecutions()` function to use `theme_classic()` as the theme, rather than `theme_grey()`. Produce a plot of the breakdown of the number of prosecutions over time, with a breakdown by `"offence_group"`. 962 | 963 | --- 964 | 965 | ```{r, include=show_solution, purl=purl_solutions} 966 | # Exercise 6 solution 967 | plot_prosecutions <- function(df, breakdown = "offence_type") { 968 | 969 | df_grouped <- df |> 970 | dplyr::group_by(.data[[breakdown]], year) |> 971 | dplyr::summarise(counts = sum(count), .groups = "keep") 972 | 973 | df_grouped |> 974 | ggplot2::ggplot( 975 | ggplot2::aes(x = .data$year, 976 | y = .data$counts, 977 | group = .data[[breakdown]], 978 | col = .data[[breakdown]]) 979 | ) + 980 | ggplot2::geom_line() + 981 | ggplot2::scale_x_continuous(breaks = 0:2100) + 982 | ggplot2::theme_classic() 983 | } 984 | ``` 985 | 986 | --- 987 | 988 | ```{r fig.width=10, include=show_solution, purl=purl_solutions} 989 | # Exercise 6 solution 990 | 991 | plot_prosecutions(prosecutions, breakdown = "offence_group") 992 | ``` 993 | 994 | 995 | 996 | ## Assertions 997 | 998 | In both development and deployment, the effects of functions can differ from that which is expected. If you have experienced such problems while writing and executing custom functions in the above exercises, you may have seen an error message. 999 | 1000 | Beyond those generated by basic syntax mistakes, any error messages that you have seen while executing a custom function will have originated from the functions that your custom function calls. They are by nature generic. Sometimes, these error messages will be easy for you to understand, and therefore see what's gone wrong, but because they are generic, their meaning in any given context is not necessary clear. 1001 | 1002 | You may also have noticed that a function you wrote wasn't doing what you wanted because the output was surprising, even though no error was generated. 1003 | 1004 | ```{r purl=purl_example_code, error = TRUE} 1005 | my_mean <- function(x, y) { 1006 | x + y / 2 1007 | } 1008 | 1009 | my_mean(3, 5) 1010 | 1011 | ``` 1012 | 1013 | --- 1014 | 1015 | Although this is a frivolous example, and the problem immediately obvious, in general this issue is serious and pernicious, because a problem may exist that you're not immediately aware of. Alternatively, you may be able to tell that there is a problem somewhere, but not know what the root cause is, particularly when your custom functions get more complex, or when you're calling custom functions from within other custom functions. 1016 | 1017 | You can make life easier by adding _assertions_ (calls to assertion functions). 1018 | 1019 | An assertion function call accepts a condition, and stops the function execution if that condition is not met. You can use them to check that inputs, outputs and intermediate objects are as expected. You can also get them to generate bespoke error messages that are specific to your custom function, and helpful to the user. 1020 | 1021 | A good package - developed by the RStudio (Posit) people - is `assertthat`. It is extremely easy to use. We will focus on the most useful function, `assertthat::assert_that()`. 1022 | 1023 | The first - and only essential - argument that `assertthat::assert_that()` takes is an expression that returns either `TRUE` or `FALSE`. It's very useful for causing your functions to fail when objects do not meet the conditions you expect. 1024 | 1025 | Here we work with a toy function, `pythagoras()`. It calculates the length of a right-angled triangle's hypotenuse side, given the lengths of the other two sides. However, it will return a result for negative numbers, and this is not ideal behavior in the context of geometry. 1026 | 1027 | --- 1028 | 1029 | ```{r, purl=purl_example_code, error = TRUE} 1030 | # Function to calculate the length of a hypotenuse 1031 | pythagoras <- function(a, b) { 1032 | 1033 | c <- sqrt(a^2 + b^2) 1034 | 1035 | paste0("The length of the hypotenuse is ", c) 1036 | 1037 | } 1038 | 1039 | pythagoras(2, -3) 1040 | 1041 | ``` 1042 | 1043 | --- 1044 | 1045 | We can add assertion statements to prevent this undesirable behaviour. 1046 | 1047 | ```{r, purl=purl_example_code, error = TRUE} 1048 | # Function to calculate the length of a hypotenuse 1049 | pythagoras <- function(a, b) { 1050 | 1051 | assertthat::assert_that(a > 0) 1052 | assertthat::assert_that(b > 0) 1053 | 1054 | c <- sqrt(a^2 + b^2) 1055 | 1056 | paste0("The length of the hypotenuse is ", c) 1057 | 1058 | } 1059 | 1060 | pythagoras(2, -3) 1061 | 1062 | ``` 1063 | 1064 | --- 1065 | 1066 | That's great, but we could improve clarity. The second most useful argument that `assertthat::assert_that()` takes is `msg`. This is a string that will be output as part of the error message, overriding the default, e.g. 1067 | 1068 | ```{r, purl=purl_example_code, error = TRUE} 1069 | # Function to calculate the length of a hypotenuse 1070 | pythagoras <- function(a, b) { 1071 | 1072 | assertthat::assert_that( 1073 | a > 0 && b > 0, 1074 | msg = "both triangle sides must have positive length!") 1075 | 1076 | c <- sqrt(a^2 + b^2) 1077 | 1078 | paste0("The length of the hypotenuse is ", c) 1079 | 1080 | } 1081 | 1082 | pythagoras(-2, 1) 1083 | 1084 | ``` 1085 | 1086 | (Here we also combine the two assertions into one, to avoid repetition.) 1087 | 1088 | --- 1089 | 1090 | In this final example, additional assertions are added to check more fundamental aspects of input. 1091 | 1092 | ```{r, purl=purl_example_code, error = TRUE} 1093 | # Function to calculate the length of a hypotenuse 1094 | pythagoras <- function(a, b) { 1095 | 1096 | assertthat::assert_that( 1097 | !missing(a) && !missing(b), 1098 | msg = "you must supply two triangle lengths") 1099 | 1100 | assertthat::assert_that( 1101 | is.numeric(a) && is.numeric(b), 1102 | msg = "both arguments must be of numeric data type") 1103 | 1104 | assertthat::assert_that( 1105 | a > 0 && b > 0, 1106 | msg = "both triangle sides must have positive length!") 1107 | 1108 | sqrt(a^2 + b^2) 1109 | 1110 | } 1111 | 1112 | ``` 1113 | 1114 | --- 1115 | 1116 | ```{r, purl=purl_example_code, error = TRUE} 1117 | pythagoras("1", 2) 1118 | 1119 | pythagoras(b = 2) 1120 | ``` 1121 | 1122 | --- 1123 | 1124 | ### Exercise 7 1125 | 1126 | In the final exercise, we will apply `assertthat::assert_that()` to the end product before returning it to the user. 1127 | 1128 | We will make a new function, called `pythagorus_rounded()`. 1129 | 1130 | 1. Add the below assertion to `pythagorus()` in the correct place to test the value that is reported. Reload the function and confirm that it fails with positive numeric inputs. 1131 | 2. Add a message to the assertion to explain why it fails. Reload the function and confirm that failure with this message occurs with positive numeric inputs. 1132 | 3. Modify the function so that the assertion passes and the function succeeds. Reload the function and confirm that it passes with positive numeric inputs. 1133 | 1134 | 1135 | ```{r, purl_example_code, error = TRUE, eval = FALSE} 1136 | # Exercise 7 assertion statement 1137 | 1138 | assertthat::assert_that(c %% 1 == 0) 1139 | 1140 | ``` 1141 | 1142 | --- 1143 | 1144 | ### Exercise 7 Answers 1145 | 1146 | ```{r, include=show_solution, purl=purl_solutions, error = TRUE} 1147 | # Exercise 7 solution - function to return hypotenuse length rounded to whole number 1148 | pythagoras_rounded <- function(a, b) { 1149 | 1150 | assertthat::assert_that( 1151 | !missing(a) && !missing(b), 1152 | msg = "you must supply two triangle lengths") 1153 | 1154 | assertthat::assert_that( 1155 | is.numeric(a) && is.numeric(b), 1156 | msg = "both arguments must be of numeric data type") 1157 | 1158 | assertthat::assert_that( 1159 | a > 0 && b > 0, 1160 | msg = "both triangle sides must have positive length!") 1161 | 1162 | # round the value to ensure it passes the assertion 1163 | c <- round(sqrt(a^2 + b^2)) 1164 | 1165 | # assertion statement checks that rounding has occurred 1166 | assertthat::assert_that( 1167 | c %% 1 == 0, 1168 | msg = "calculated answer is not a whole number") 1169 | 1170 | paste0("The rounded length of the hypotenuse is ", c) 1171 | } 1172 | ``` 1173 | 1174 | --- 1175 | 1176 | 1177 | ```{r, include=show_solution, purl=purl_solutions, error = TRUE} 1178 | pythagoras_rounded(2, 3) 1179 | ``` 1180 | 1181 | # Hints and tips 1182 | 1183 | ## When to write a function 1184 | 1185 | ### When you've copied and pasted two times 1186 | There is a principal in software engineering called Don't Repeat Yourself (DRY) - which basically states that you should avoid duplication wherever possible. A good rule of thumb is whenever you find you've used the same or similar code in three places, it's time to consider replacing that code with a function. 1187 | 1188 | ### To structure your code 1189 | You may also sometimes want to write a function for code you're only planning to use once as a way of structuring your code and "hiding" some of it to make your main script easier to read. 1190 | 1191 | ### When someone hasn't already written one for you 1192 | The R ecosystem is full of high quality packages designed to solve all kinds of problems - it's generally best to make sure that a function doesn't already exist before writing your own. 1193 | 1194 | ## Best practice 1195 | Writing a function is easy, writing a really good function can be a lot harder! Here are a few things to consider: 1196 | 1197 | ### Give your function a good name 1198 | The name of a function should give you a good idea of what it does. Generally function names should be concise and use verbs rather than nouns. 1199 | 1200 | ### Pass variables into the function as arguments 1201 | While functions can access objects that haven't been passed in as an argument, this 1202 | is generally bad practice as it makes code much harder to understand and modify, 1203 | and makes the function itself harder to reuse. 1204 | 1205 | ### Document your code 1206 | You should have comments explaining what your function does, what each argument is, and what it returns. 1207 | 1208 | --- 1209 | 1210 | ### Keep it short 1211 | A rule of thumb is if all the code for your function doesn't fit on your screen at the same time, it's probably too complicated. Consider splitting it up into multiple functions. 1212 | 1213 | ### Generalise 1214 | Think about whether there are ways you can make your function usable in more situations. For example, is there anything you're hard-coding that you could set as an argument instead? 1215 | 1216 | ### Vectorise by default 1217 | R is designed to work well with vectors (e.g. columns of a dataframe). Where possible you should write your function so it can take a vector as an input and apply the transformation to each element. The `generalise_names()` function we looked at is a good example of this! 1218 | 1219 | ### Ask for feedback 1220 | A key measure of a good function (or any piece of code) is how easy it is for someone else to understand, use and modify it. The best way to test this is to get your code reviewed by someone else. 1221 | 1222 | ## How to organise your code 1223 | 1224 | Whenever you're working on something in R it's generally best to create an R project and version control your code on GitHub. There's information on how to do this in the [Analytical Platform guidance](https://user-guidance.analytical-platform.service.justice.gov.uk/index.html). 1225 | 1226 | It's also best to keep your functions separate from the rest of your code to make them easier to find. 1227 | 1228 | ### Storing your functions in your project 1229 | 1230 | The easiest way to store your functions is just to create a folder in your project called "functions" and save your functions there. 1231 | 1232 | You could either put each function in its own R script with the same name, or you could group related functions into clearly named scripts. 1233 | 1234 | Then just use `source("functions/my_functions_script.R")` (with `functions/` and `my_functions_script.R` replaced with the name of the folder and the name of your script, respectively) to run the code and make your functions available to you in the current session. As with loading packages, it's best to do this at the top of your script. 1235 | 1236 | --- 1237 | 1238 | Here's an example of calling a script that contains a new function, called `pick_a_colour()`: 1239 | 1240 | ```{r, purl=purl_example_code} 1241 | source("functions.R") 1242 | ``` 1243 | 1244 | Now the function is ready to use: 1245 | 1246 | ```{r, purl=purl_example_code} 1247 | # Create a list of colours to provide to the function 1248 | colours <- c("Red", "Blue", "Green", "Magenta", "Cyan", "Yellow", "Purple", "Pink") 1249 | pick_a_colour(colours) 1250 | ``` 1251 | --- 1252 | You can see the code underlying a function by typing its name (without brackets) in the console and hitting "enter": 1253 | 1254 | ```{r, purl=purl_example_code} 1255 | pick_a_colour 1256 | ``` 1257 | 1258 | ## Writing a package 1259 | 1260 | An alternative is to make your own package to store your functions, which you can then use like any other R package. There are a few advantages to this: 1261 | 1262 | + It means you (and others) can access your functions from different projects 1263 | + There are certain requirements for making R packages that enforce good practice, such as including documentation 1264 | 1265 | This comes at the cost of slightly higher overheads. 1266 | 1267 | Examples of packages written by people in MoJ are available [here](https://github.com/moj-analytical-services/mojRpackages). 1268 | 1269 | To find out more about writing packages, check out the links under further reading. 1270 | 1271 | ## Further reading 1272 | #### On functions 1273 | + [Functions chapter](https://r4ds.hadley.nz/functions) of Hadley's R for Data Science book 1274 | + [Functions chapter](https://adv-r.hadley.nz/functions.html) of Hadley's Advanced R book 1275 | + [Tidy Evaluation](https://dplyr.tidyverse.org/articles/programming.html) (useful for writing functions which behave like Tidyverse functions) 1276 | 1277 | #### On packages 1278 | + [MoJ R package training](https://github.com/moj-analytical-services/rpackage_training) 1279 | + [Writing an R package from scratch](https://hilaryparker.com/2014/04/29/writing-an-r-package-from-scratch/) 1280 | + Hadley's [R packages](https://r-pkgs.org/) book 1281 | 1282 | #### On loops 1283 | + [Iteration chapter](https://r4ds.hadley.nz/iteration) of Hadley's R for Data Science book 1284 | 1285 | #### Misc 1286 | + [Tidyverse style guide](https://style.tidyverse.org/) (has some guidance on choosing function and argument names) 1287 | + [MoJ coding standards](https://github.com/moj-analytical-services/our-coding-standards) 1288 | + [Scoping/environments](https://bookdown.org/rdpeng/rprogdatascience/scoping-rules-of-r.html) 1289 | 1290 | ## Get help 1291 | 1292 | If you get stuck, a great place to ask is [ASD slack](https://asdslack.slack.com/) on either the `#r` or `#intro_r` channels. 1293 | 1294 | -------------------------------------------------------------------------------- /rmd_files/functions.R: -------------------------------------------------------------------------------- 1 | # We can collect functions together in this R script 2 | 3 | 4 | pick_a_colour <- function(colours){ 5 | 6 | # Generate a random number between 1 and the number of colours provided 7 | x <- sample(1:length(colours), 1) 8 | 9 | # Print a randomly chosen colour 10 | print(colours[x]) 11 | 12 | } -------------------------------------------------------------------------------- /rmd_files/render_rmarkdown_files.R: -------------------------------------------------------------------------------- 1 | # Render markdowns 2 | 3 | ### Render README.Rmd as GitHub markdown document -------------------------------------------------- 4 | # Note: this includes rmd_files/content.Rmd and rmd_files/appendix.Rmd. 5 | rmarkdown::render( 6 | "rmd_files/README.Rmd", 7 | output_format = "github_document", 8 | output_dir = here::here(), 9 | output_file = here::here("README.md") 10 | ) 11 | 12 | here::here("README.html") |> file.remove() 13 | 14 | ### Render slides.html as an isoslides presentation ------------------------------------------------ 15 | # Note: this includes rmd_files/content.Rmd. 16 | rmarkdown::render( 17 | "rmd_files/slides.Rmd", 18 | output_format = "ioslides_presentation", 19 | output_dir = here::here(), 20 | output_file = here::here("slides.html") 21 | ) 22 | 23 | 24 | ### Extract the example code chunks into an R script ----------------------------------------------- 25 | # Note: purl flags are set in the global environment prior to extracting the code. 26 | purl_solutions <- FALSE 27 | purl_example_code <- TRUE 28 | knitr::purl( 29 | here::here("rmd_files/content.Rmd"), 30 | documentation = 1, 31 | output = here::here("example_code.R") 32 | ) 33 | rm(purl_solutions, purl_example_code) 34 | 35 | 36 | ### Extract the solution code chunks into an R script ---------------------------------------------- 37 | # Note: purl flags are set in the global environment prior to extracting the code. 38 | purl_solutions <- TRUE 39 | purl_example_code <- FALSE 40 | knitr::purl( 41 | here::here("rmd_files/content.Rmd"), 42 | documentation = 1, 43 | output = here::here("solutions.R") 44 | ) 45 | rm(purl_solutions, purl_example_code) 46 | 47 | 48 | -------------------------------------------------------------------------------- /rmd_files/slides.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: Writing functions in R 3 | output: 4 | ioslides_presentation: 5 | widescreen: true 6 | smaller: true 7 | knit: (function(input, ...) { 8 | rmarkdown::render( 9 | input, 10 | output_dir = "../", 11 | output_file = file.path("../slides.html") 12 | ) 13 | }) 14 | --- 15 | 16 | ```{r setup, include=FALSE} 17 | # These variables determine whether or not exercise solutions are included 18 | show_solution <- TRUE # This determines if the solutions are displayed in the slides 19 | purl_solutions <- FALSE # This variable relates to code blocks that are exercise solutions 20 | purl_example_code <- TRUE # This variable relates to code blocks that aren't exercise solutions 21 | knitr::opts_chunk$set( 22 | comment = "#>" 23 | ) 24 | ``` 25 | 26 | ## Writing functions in R: setup 27 | 28 | Before we start, make sure you've: 29 | 30 | 1. Got access to the `alpha-r-training` bucket 31 | 2. Cloned the [writing_functions_in_r](https://github.com/moj-analytical-services/writing_functions_in_r) repo into your RStudio 32 | 3. Pulled any changes (the blue arrow on the Git tab in the top right panel) 33 | 4. Got `example_code.R` open in RStudio 34 | 5. Run the command `renv::restore()` in the RStudio console to make sure you have the required packages installed 35 | 6. Opened the [writing_functions_in_r](https://github.com/moj-analytical-services/writing_functions_in_r) repo on GitHub, so you can refer to the README 36 | 37 | If you need any help, just ask! We will be monitoring the Teams chat throughout the session. 38 | 39 | ## Agenda 40 | 41 | Item | Time 42 | ---------------------------------------------------- | ------------- 43 | Set up and introduction | 10:00 - 10:10 44 | Examples of basic functions (including exercises) | 10:10 - 11:30 45 | Break | 11:30 - 11:40 46 | 'Real-world' example functions (including exercises) | 11:40 - 12:30 47 | Using `assertthat` | 12:30 - 12:50 48 | Hints and tips | 12:50 - 13:00 49 | 50 | ```{r source_content, child = 'content.Rmd'} 51 | ``` 52 | 53 | # Any questions? 54 | -------------------------------------------------------------------------------- /solutions.R: -------------------------------------------------------------------------------- 1 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 2 | # 1.1 hello_world() solution 3 | 4 | hello_world <- function() { 5 | print("Hello world!") 6 | } 7 | 8 | hello_world() 9 | 10 | 11 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 12 | # 1.2 my_mean() solution 13 | 14 | my_mean <- function(x, y) { 15 | (x + y) / 2 16 | } 17 | 18 | my_mean(7.5, 16) 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 | ## ----include=show_solution, purl=purl_solutions, eval=TRUE--------------------------------------------------------------------------------------- 44 | # 2.1 fizz_buzz() solution 45 | 46 | fizz_buzz <- function(x) { 47 | 48 | if (x %% 3 == 0 && x %% 5 == 0) { 49 | "fizz buzz" 50 | } else if (x %% 3 == 0) { 51 | "fizz" 52 | } else if (x %% 5 == 0) { 53 | "buzz" 54 | } else { 55 | as.character(x) 56 | } 57 | 58 | } 59 | 60 | 61 | ## ----include=show_solution, purl=purl_solutions, eval=FALSE-------------------------------------------------------------------------------------- 62 | ## fizz_buzz(1) # "1" 63 | ## fizz_buzz(2) # "2" 64 | ## fizz_buzz(3) # "fizz" 65 | ## fizz_buzz(5) # "buzz" 66 | ## fizz_buzz(15) # "fizz buzz" 67 | 68 | 69 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 70 | # 2.2 fizz_buzz_vec() solution 71 | 72 | fizz_buzz_vec <- function(x) { 73 | 74 | dplyr::case_when( 75 | x %% 3 == 0 & x %% 5 == 0 ~ "fizz buzz", 76 | x %% 3 == 0 ~ "fizz", 77 | x %% 5 == 0 ~ "buzz", 78 | TRUE ~ as.character(x) 79 | ) 80 | 81 | } 82 | 83 | fizz_buzz_vec(1:15) 84 | 85 | 86 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 87 | # 2.3 fizz_buzz_custom() solution 88 | 89 | fizz_buzz_custom <- function(x, fizz = 3, buzz = 5) { 90 | 91 | if (x %% fizz == 0 & x %% buzz == 0) { 92 | "fizz buzz" 93 | } else if (x %% fizz == 0) { 94 | "fizz" 95 | } else if (x %% buzz == 0) { 96 | "buzz" 97 | } else { 98 | as.character(x) 99 | } 100 | 101 | } 102 | 103 | 104 | fizz_buzz_custom_vec <- function(x, fizz = 3, buzz = 5) { 105 | 106 | dplyr::case_when( 107 | x %% fizz == 0 & x %% buzz == 0 ~ "fizz buzz", 108 | x %% fizz == 0 ~ "fizz", 109 | x %% buzz == 0 ~ "buzz", 110 | TRUE ~ as.character(x) 111 | ) 112 | 113 | } 114 | 115 | 116 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 117 | fizz_buzz_custom_vec(1:15) 118 | fizz_buzz_custom_vec(c(1, 2, 3, 7, 15, 21), buzz = 7) 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 138 | # Exercise 3 solution 139 | colnames(prosecutions) <- colnames(prosecutions) |> generalise_names() 140 | dplyr::glimpse(prosecutions) 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 156 | # Exercise 4 solution 157 | 158 | clean_not_known <- function(x, 159 | not_known_phrase = "Not known", 160 | change_na = TRUE, 161 | values_to_change = c("n/a", "not known", "unknown", "not stated")) { 162 | 163 | # Replace any missing (NA) values 164 | if (change_na) { 165 | x <- replace(x, list = is.na(x), values = not_known_phrase) 166 | } 167 | 168 | # Remove any white space that might cause the strings to not match 169 | x <- stringr::str_trim(x) 170 | 171 | # Replace strings in the data that refer to a missing or unknown value. 172 | dplyr::if_else(tolower(x) %in% values_to_change, true = not_known_phrase, false = x) 173 | 174 | } 175 | 176 | 177 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 178 | # Exercise 5 solution 179 | 180 | clean_dataset <- function(data) { 181 | 182 | # Clean the column headings 183 | colnames(data) <- generalise_names(colnames(data)) 184 | 185 | # Remove numeric indices from columns 186 | data <- dplyr::mutate( 187 | data, 188 | dplyr::across( 189 | .cols = tidyselect::where(is.character), 190 | .fns = remove_numbering 191 | ) 192 | ) 193 | 194 | # Make missing/unknown value entries more consistent 195 | dplyr::mutate( 196 | data, 197 | dplyr::across( 198 | .cols = tidyselect::where(is.character), 199 | .fns = clean_not_known 200 | ) 201 | ) 202 | 203 | } 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | ## ----include=show_solution, purl=purl_solutions-------------------------------------------------------------------------------------------------- 227 | # Exercise 6 solution 228 | plot_prosecutions <- function(df, breakdown = "offence_type") { 229 | 230 | df_grouped <- df |> 231 | dplyr::group_by(.data[[breakdown]], year) |> 232 | dplyr::summarise(counts = sum(count), .groups = "keep") 233 | 234 | df_grouped |> 235 | ggplot2::ggplot( 236 | ggplot2::aes(x = .data$year, 237 | y = .data$counts, 238 | group = .data[[breakdown]], 239 | col = .data[[breakdown]]) 240 | ) + 241 | ggplot2::geom_line() + 242 | ggplot2::scale_x_continuous(breaks = 0:2100) + 243 | ggplot2::theme_classic() 244 | } 245 | 246 | 247 | ## ----fig.width=10, include=show_solution, purl=purl_solutions------------------------------------------------------------------------------------ 248 | # Exercise 6 solution 249 | 250 | plot_prosecutions(prosecutions, breakdown = "offence_group") 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | ## ----purl_example_code, error = TRUE, eval = FALSE----------------------------------------------------------------------------------------------- 266 | ## # Exercise 7 assertion statement 267 | ## 268 | ## assertthat::assert_that(c %% 1 == 0) 269 | ## 270 | 271 | 272 | ## ----include=show_solution, purl=purl_solutions, error = TRUE------------------------------------------------------------------------------------ 273 | # Exercise 7 solution - function to return hypotenuse length rounded to whole number 274 | pythagoras_rounded <- function(a, b) { 275 | 276 | assertthat::assert_that( 277 | !missing(a) && !missing(b), 278 | msg = "you must supply two triangle lengths") 279 | 280 | assertthat::assert_that( 281 | is.numeric(a) && is.numeric(b), 282 | msg = "both arguments must be of numeric data type") 283 | 284 | assertthat::assert_that( 285 | a > 0 && b > 0, 286 | msg = "both triangle sides must have positive length!") 287 | 288 | # round the value to ensure it passes the assertion 289 | c <- round(sqrt(a^2 + b^2)) 290 | 291 | # assertion statement checks that rounding has occurred 292 | assertthat::assert_that( 293 | c %% 1 == 0, 294 | msg = "calculated answer is not a whole number") 295 | 296 | paste0("The rounded length of the hypotenuse is ", c) 297 | } 298 | 299 | 300 | ## ----include=show_solution, purl=purl_solutions, error = TRUE------------------------------------------------------------------------------------ 301 | pythagoras_rounded(2, 3) 302 | 303 | --------------------------------------------------------------------------------