diff --git a/R/create-map-polygon.R b/R/create-map-polygon.R index 14dab68..e8895ac 100644 --- a/R/create-map-polygon.R +++ b/R/create-map-polygon.R @@ -32,7 +32,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi d })() |> filter(STATE_NAME == "Queensland") |> - remove_empty_polygons() |> + remove_empty_polygons() |> rmapshaper::ms_simplify(keep = simplify_keep, keep_shapes = TRUE) |> select(all_of(c("SA1_CODE", "SA2_NAME"))) |> mutate(SA_level = 1) |> @@ -64,7 +64,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi d })() |> filter(STATE_NAME == "Queensland") |> - remove_empty_polygons() |> + remove_empty_polygons() |> rmapshaper::ms_simplify(keep = simplify_keep, keep_shapes = TRUE) |> select(all_of(c("SA2_CODE", "SA2_NAME"))) |> mutate(SA_level = 2) |> @@ -99,7 +99,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi "value_rehab", "SA_level" ) - + sa2_all <- sa2_poly |> left_join(sa2_rehab) |> left_join(sa2_acute) |> @@ -111,70 +111,69 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi left_join(sa1_acute) |> rename(CODE = SA1_CODE) |> select(all_of(cols)) - + sa2_polygon <- sa2_all |> select(CODE) |> st_cast("MULTIPOLYGON") |> st_cast("POLYGON") - - sa2_linestring <- sa2_polygon |> - st_cast("LINESTRING") |> - group_by(CODE) |> - mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> + + sa2_linestring <- sa2_polygon |> + st_cast("LINESTRING") |> + group_by(CODE) |> + mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> ungroup() - - sa1_polygon <- sa1_all |> - select(CODE) |> - st_cast("MULTIPOLYGON") |> - st_cast("POLYGON") |> - group_by(CODE) |> - mutate(layerid = glue("{CODE}-polygon-{row_number()}")) |> + + sa1_polygon <- sa1_all |> + select(CODE) |> + st_cast("MULTIPOLYGON") |> + st_cast("POLYGON") |> + group_by(CODE) |> + mutate(layerid = glue("{CODE}-polygon-{row_number()}")) |> ungroup() - - - sa1_linestring <- sa1_polygon |> - st_cast("LINESTRING") |> - group_by(CODE) |> - mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> + + + sa1_linestring <- sa1_polygon |> + st_cast("LINESTRING") |> + group_by(CODE) |> + mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> ungroup() - + sa1_sa2_code_lkp <- strayr::read_absmap(glue("sa1{asgs_year}")) |> - filter(sa1_code_2016 %in% sa1_all$CODE) |> + filter(sa1_code_2016 %in% sa1_all$CODE) |> as_tibble() |> - select(starts_with("sa1_code"), starts_with("sa2_code")) |> + select(starts_with("sa1_code"), starts_with("sa2_code")) |> rename(sa1_code = 1, sa2_code = 2) - - stacked_sa1_sa2_polygons <- rbind(sa1_all, sa2_all) |> + + stacked_sa1_sa2_polygons <- rbind(sa1_all, sa2_all) |> mutate( value_index = get_index_function(acute_mins = value_acute, rehab_mins = value_rehab), rehab_time_str = str_extract(popup_rehab, "Time to.*$"), popup_index = paste0(popup_acute, rehab_time_str, "iTRAQI Index: ", value_index, "
") - ) - - - stacked_sa1_sa2_data <- stacked_sa1_sa2_polygons |> - as_tibble() |> + + + stacked_sa1_sa2_data <- stacked_sa1_sa2_polygons |> + as_tibble() |> select(-geometry) - + linestring_layerid_lkp <- bind_rows(sa1_linestring, sa2_linestring) |> as_tibble() |> select(-geometry) |> mutate(type = "linestring") - + sa1_polygon_lkp <- sa1_polygon |> as_tibble() |> select(-geometry) - + polygon_layerid_lkp <- sa1_sa2_code_lkp |> inner_join(sa1_polygon_lkp, by = c("sa1_code" = "CODE")) |> pivot_longer(!layerid, values_to = "CODE") |> select(-name) |> mutate(type = "polygon") - + sa_code_layerid_lkp <- bind_rows(linestring_layerid_lkp, polygon_layerid_lkp) - + saveRDS(sa2_polygon, file.path(output_dir, "sa2_polygon.rds")) saveRDS(sa2_linestring, file.path(output_dir, "sa2_linestring.rds")) saveRDS(sa1_polygon, file.path(output_dir, "sa1_polygon.rds")) @@ -184,24 +183,24 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi saveRDS(sa1_sa2_code_lkp, file.path(output_dir, "sa1_sa2_code_lkp.rds")) saveRDS(stacked_sa1_sa2_data, file.path(app_data_dir, "stacked_sa1_sa2_data.rds")) saveRDS(sa_code_layerid_lkp, file.path(output_dir, "sa_code_layerid_lkp.rds")) - - - - stacked_sa1_sa2_polygon_geom <- rbind(sa1_all, sa2_all) |> - st_cast("MULTIPOLYGON") |> - st_cast("POLYGON") |> + + + + stacked_sa1_sa2_polygon_geom <- rbind(sa1_all, sa2_all) |> + st_cast("MULTIPOLYGON") |> + st_cast("POLYGON") |> select(CODE) - + saveRDS(stacked_sa1_sa2_polygon_geom, file.path(app_data_dir, "stacked_SA1_and_SA2_polygons_geom.rds")) - - stacked_sa1_sa2_linestring_geom <- stacked_sa1_sa2_polygon_geom |> - st_cast("LINESTRING") |> + + stacked_sa1_sa2_linestring_geom <- stacked_sa1_sa2_polygon_geom |> + st_cast("LINESTRING") |> select(CODE) - + saveRDS(stacked_sa1_sa2_linestring_geom, file.path(app_data_dir, "stacked_SA1_and_SA2_linestrings_geom.rds")) - - - + + + saveRDS(stacked_sa1_sa2_polygons, file.path(output_dir, "stacked_SA1_and_SA2_polygons.rds")) file.path(output_dir, "stacked_SA1_and_SA2_polygons.rds") diff --git a/R/save-app-markers.R b/R/save-app-markers.R index 71ccbb5..e0a70e9 100644 --- a/R/save-app-markers.R +++ b/R/save-app-markers.R @@ -1,41 +1,41 @@ save_app_markers <- function(vis_shapes, d_centre_coords) { marker_cols <- c("x", "y", "popup") - - d_acute_centres <- d_centre_coords |> - as_tibble() |> - filter(care_type == "acute") |> - mutate(popup = "placeholder acute centre popup") |> + + d_acute_centres <- d_centre_coords |> + as_tibble() |> + filter(care_type == "acute") |> + mutate(popup = "placeholder acute centre popup") |> select(name = centre_name, all_of(marker_cols)) - - d_rehab_centres <- d_centre_coords |> - as_tibble() |> - filter(care_type == "rehab") |> - mutate(popup = "placeholder rehab centre popup") |> + + d_rehab_centres <- d_centre_coords |> + as_tibble() |> + filter(care_type == "rehab") |> + mutate(popup = "placeholder rehab centre popup") |> select(name = centre_name, all_of(marker_cols)) - + d_towns <- vis_shapes$town_locations |> - as_tibble() |> - mutate(popup = "town marker placeholder text") |> + as_tibble() |> + mutate(popup = "town marker placeholder text") |> select(name = Location, all_of(marker_cols)) - - d_qas_locations <- vis_shapes$qas_locations |> - as_tibble() |> - mutate(popup = glue::glue("Location: ", "{qas_location}
")) |> + + d_qas_locations <- vis_shapes$qas_locations |> + as_tibble() |> + mutate(popup = glue::glue("Location: ", "{qas_location}
")) |> select(name = qas_location, all_of(marker_cols)) - - d_rsq_locations <- vis_shapes$rsq_locations |> - as_tibble() |> + + d_rsq_locations <- vis_shapes$rsq_locations |> + as_tibble() |> mutate( type = str_to_sentence(ifelse(type == "both", "plane and helicopter", type)), popup = glue::glue( "Location: ", "{rsq_location}
", "Service: ", "{type}" ) - ) |> - select(name = rsq_location, all_of(marker_cols)) |> + ) |> + select(name = rsq_location, all_of(marker_cols)) |> distinct() - - + + l <- list( d_acute_centres = d_acute_centres, d_rehab_centres = d_rehab_centres, @@ -43,8 +43,8 @@ save_app_markers <- function(vis_shapes, d_centre_coords) { d_qas_locations = d_qas_locations, d_towns = d_towns ) - + saveRDS(l, file.path(app_data_dir, "l_markers.rds")) - + file.path(app_data_dir, "l_markers.rds") -} \ No newline at end of file +} diff --git a/R/save-app-qld-boundary.R b/R/save-app-qld-boundary.R index 377b2bb..7dd7800 100644 --- a/R/save-app-qld-boundary.R +++ b/R/save-app-qld-boundary.R @@ -1,6 +1,6 @@ save_qld_boundary <- function(state_boundary) { state_boundary_simplified <- rmapshaper::ms_simplify(state_boundary, keep = 0.03) - + saveRDS(state_boundary_simplified, file.path(app_data_dir, "state_boundary.rds")) file.path(app_data_dir, "state_boundary.rds") -} \ No newline at end of file +} diff --git a/R/save-app-scales.R b/R/save-app-scales.R index 39e3db1..8803d59 100644 --- a/R/save-app-scales.R +++ b/R/save-app-scales.R @@ -6,7 +6,7 @@ save_app_scale_fxs <- function(itraqi_list) { ra_text_to_value = ra_text_to_value, itraqi_index = itraqi_list$iTRAQI_index ) - + saveRDS(fx_list, file.path(app_data_dir, "scale_fxs.rds")) file.path(app_data_dir, "scale_fxs.rds") } @@ -41,4 +41,4 @@ ra_text_to_value <- function(x) { x == "Remote Australia" ~ 3, x == "Very Remote Australia" ~ 4, ) -} \ No newline at end of file +} diff --git a/R/utils-cleaning.R b/R/utils-cleaning.R index 8331222..ea6d12d 100644 --- a/R/utils-cleaning.R +++ b/R/utils-cleaning.R @@ -32,5 +32,5 @@ centre_renaming <- function(x) { } remove_empty_polygons <- function(x) { - x[!st_is_empty(x),,drop=FALSE] + x[!st_is_empty(x), , drop = FALSE] } diff --git a/R/vis-iTRAQI-index.R b/R/vis-iTRAQI-index.R index a8d3dde..784bbc4 100644 --- a/R/vis-iTRAQI-index.R +++ b/R/vis-iTRAQI-index.R @@ -1,5 +1,4 @@ get_iTRAQI_vis_objs <- function(shapes, - palette_file, kriged_rehab, kriged_acute, itraqi_breaks, @@ -62,11 +61,37 @@ get_iTRAQI_vis_objs <- function(shapes, iTRAQI_bins <- get_iTRAQI_bins() - index_palette <- read.csv(palette_file) + index_palette <- tibble( + # from Susanna's email and shown on issue #1 on GitHub + index = c( + "1A", "2A", "3A", "3B", "3C", "4A", + "4B", "4C", "5B", "5C" + ), r = c( + 255L, 255L, 255L, 255L, 255L, + 230L, 220L, 196L, 140L, 95L + ), g = c( + 230L, 191L, 136L, 110L, 78L, + 60L, 30L, 0L, 0L, 0L + ), b = c( + 153L, 47L, 83L, 36L, 19L, 66L, 72L, + 78L, 78L, 78L + ) + ) + + index_palette$hex <- NA + + for (i in 1:nrow(index_palette)) { + index_palette$hex[i] <- rgb( + r = index_palette$r[i], + g = index_palette$g[i], + b = index_palette$b[i], + maxColorValue = 255 + ) + } paliTRAQI <- colorFactor( # https://stackoverflow.com/questions/44269655/ggplot-rcolorbrewer-extend-and-apply-to-factor-data - index_palette$hex2, + index_palette$hex, levels = levels(iTRAQI_bins), ordered = FALSE ) @@ -89,6 +114,7 @@ get_iTRAQI_vis_objs <- function(shapes, iTRAQI_acute_breaks = iTRAQI_acute_breaks, iTRAQI_rehab_breaks = iTRAQI_rehab_breaks, iTRAQI_index = get_iTRAQI_index, + index_palette = index_palette, bins = bins, iTRAQI_bins = iTRAQI_bins, palNum_hours = palNum_hours, diff --git a/R/vis-make-tables.R b/R/vis-make-tables.R index c880b30..7935481 100644 --- a/R/vis-make-tables.R +++ b/R/vis-make-tables.R @@ -26,7 +26,7 @@ make_itraqi_counts_tbls <- function(iTRAQI_list) { ) itraqi_counts_by_remoteness <- iTRAQI_list$qld_SA1s |> - as_tibble() |> + as_tibble() |> left_join(d_remoteness_labels, by = "ra") |> group_by(index, remoteness) |> summarize(n = n()) |> @@ -45,7 +45,7 @@ make_itraqi_counts_tbls <- function(iTRAQI_list) { ) itraqi_counts_by_seifa <- iTRAQI_list$qld_SA1s |> - as_tibble() |> + as_tibble() |> left_join(d_seifa_labels, by = "seifa_quintile") |> group_by(index, seifa) |> summarize(n = n()) |> diff --git a/_targets.R b/_targets.R index 62b6991..0ce0e2d 100644 --- a/_targets.R +++ b/_targets.R @@ -21,7 +21,7 @@ list( d_acute, read_acute_pathways(acute_times_file) ), - + # rehab (drive) times data tar_files_input( drive_times_files, @@ -447,15 +447,10 @@ list( plotting_utils, get_plotting_utils() ), - tar_target( - palette_file, - "data/inputs-for-visualisations/index_palette.csv" - ), tar_target( itraqi_list, get_iTRAQI_vis_objs( shapes = vis_shapes, - palette_file = palette_file, kriged_rehab = d_rehab_kriged_raster$kriged_layer, kriged_acute = d_acute_kriged_raster$kriged_layer, itraqi_breaks = l_itraqi_breaks, diff --git a/_targets/meta/meta b/_targets/meta/meta index 7711139..30f4a25 100644 --- a/_targets/meta/meta +++ b/_targets/meta/meta @@ -4,12 +4,12 @@ aggregate_kriging_model_to_ASGS|function|1f7585aeb5e5b0e0||||||||||||||| app_data_dir|object|21851952ded014e0||||||||||||||| app_locations_and_times|stem|71ebefa0b721712e|b1c8cc308eee02c4|8def2ef84e3833f4|1635295773|C:/Users/n10891277/R_projects/iTRAQI-analyses/output/QLD_locations_with_RSQ_times.csv|t19806.2711974937s|734ae9969a284a07|73583|file|local|vector|||1.593|| app_markers|stem|bee56fa653981a14|882f87cf9940dce8|0261b1eeed5f6576|-310036408|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/l_markers.rds|t19889.2027720603s|eab4217444e752d9|18343|file|local|vector|||0.063|| -app_palette|stem|e1ff168b8c32dc49|e24316a13bb70c3f|76b34fe2ba567e14|1089662940|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/palette_list.rds|t19889.2027980304s|166663f6d4e8b241|20522667|file|local|vector|||2.235|| +app_palette|stem|4f7d11a5487dd8f5|e24316a13bb70c3f|f609c964b94e30c2|1089662940|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/palette_list.rds|t19889.2404503391s|216ed86771a4ba67|20521968|file|local|vector|||4.703|| app_polygons|stem|890fc84d8722d7bb|5c835e7fc326dfb4|db8af67793cec2ae|292954876|C:/Users/n10891277/R_projects/iTRAQI-analyses/output/stacked_SA1_and_SA2_polygons.rds|t19889.2004332489s|ee91ddf14d98232f|1702143|file|local|vector|||33.469|repeating attributes for all subgeometries for which they may not be constant. repeating attributes for all subgeometries for which they may not be constant. repeating attributes for all subgeometries for which they may not be constant. repeating attributes for all subgeometries for which they may not be constant. repeating attributes for all subgeometries for which they may not be constant. repeating attributes for all subgeometries for which they may not be constant| app_qld_boundary|stem|e1d4d3d4ccc389e9|c7bc03799c2af346|88f41d67fb07171e|-1801628714|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/state_boundary.rds|t19889.1653079145s|2d1fa8c30ff622b4|14106|file|local|vector|||3|| app_raster|stem|c2cbf9546e160981|b13b86c57469fee5|b8786adeabdd75a5|-1751902619|C:/Users/n10891277/R_projects/iTRAQI-analyses/output/raster_points.rds|t19806.2605021909s||6312158|file|local|vector|||1.594||promise already under evaluation recursive default argument reference or earlier problems app_rasters|stem|c31f84f47f2831bd|b13b86c57469fee5|a64629c37b44022e|1306936721||t0s|f4066a65ff755f48|0|file|local|vector|||3.078|| -app_scale_fxs|stem|a7449296d7e3d06a|514b0a88839ebf2b|e3ca35bbdbd5439b|-280546199|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/scale_fxs.rds|t19889.2025749237s|a82b2e2411a903d3|27004|file|local|vector|||2.859|| +app_scale_fxs|stem|0fc94ab2d4c8c505|514b0a88839ebf2b|cdaa94a1a6af4b4a|-280546199|C:/Users/n10891277/R_projects/iTRAQI-analyses/app/app/data/scale_fxs.rds|t19889.2405038185s|dad93f2c39b4a381|26946|file|local|vector|||0.015|| breaks_to_labels|function|15aa190f0fc9cc8c||||||||||||||| cell_size_agg|object|e9200b1fe25d1e1c||||||||||||||| CELL_SIZE_METERS|object|42b194eec038fae9||||||||||||||| @@ -94,7 +94,7 @@ get_index_f|function|2ef61843fb2b902b||||||||||||||| get_input_shapes|function|c9e647ed750f1d52||||||||||||||| get_island_times|function|196ef6db78f9ade7||||||||||||||| get_iTRAQI_index|function|905c50818f01ef90||||||||||||||| -get_iTRAQI_vis_objs|function|4b07cea697c43657||||||||||||||| +get_iTRAQI_vis_objs|function|55be0d131ff36527||||||||||||||| get_new_tt_names|function|f8cd4e5a5bc1684e||||||||||||||| get_plotting_utils|function|da620ec0077e1b74||||||||||||||| get_popup_glue|function|b37f2d473c1aaef0||||||||||||||| @@ -105,17 +105,17 @@ get_travel_times|function|40b8ccb161d09656||||||||||||||| get_vis_datasets|function|6edfe006b94a3520||||||||||||||| gg|function|9eb4e57db553eb17||||||||||||||| gold_locs|object|66c403e3c86cdcfb||||||||||||||| -index_palette_table|stem|debc7de85244be73|a8df915eafb52551|f6186c202598e4d3|1831416846||t19889.2027535084s|237f91a00ac3de41|125|rds|local|vector|||2.578|| +index_palette_table|stem|debc7de85244be73|a8df915eafb52551|1f7f2e0ed987beba|1831416846||t19889.2404555814s|237f91a00ac3de41|125|rds|local|vector|||4.375|| inset_maps|stem|f51dffb7c099ecf5|ab623e80ec6aa06a|6dbd1c29a6aa20fd|1618372214||t19889.2026513922s|97f5d5ebb4412369|161|rds|local|vector|||2.688|| iTRAQI_acute_continuous_map|stem|8918cde785e5e4a6|4746fe8c9f8065d2|6a2b743cfbd45f86|29494645||t19805.2445014188s|ae3ca543e47cf4fd|166|rds|local|vector|||3.078|| -iTRAQI_acute_maps|stem|8918cde785e5e4a6|4746fe8c9f8065d2|38efc1de57bf28e3|206967308||t19889.2027207062s|ae3ca543e47cf4fd|166|rds|local|vector|||6.203|| +iTRAQI_acute_maps|stem|8918cde785e5e4a6|4746fe8c9f8065d2|7756f1d6c4912088|206967308||t19889.2406048891s|ae3ca543e47cf4fd|166|rds|local|vector|||3.984|| iTRAQI_index_counts_tbl|stem|a743647a79bd692b|d57bd319170d08e2|cd910488a7222ea4|1128743655||t19806.1611449963s|22b4442571f78ea6|657|rds|local|vector|||0.813|| -iTRAQI_legends|stem|f653617587a60336|2eb810a937c63cee|e4d0593ff1da4d72|-1228347186||t19889.2027902285s|af2f698bb96276c8|148|rds|local|vector|||3.563|| -itraqi_list|stem|6c6c118fbb354d42|6c87c5766f8a68a3|7a26a9ac27aeb942|-1855879146||t19889.2005482532s|14ee18f09bcb3120|25449971|rds|local|vector|||0.688|| -iTRAQI_rehab_maps|stem|e1261ccb6bf56ab6|fd02f3040beca726|915ae6abb69f14e3|140306304||t19889.2026799226s|3c9f22cdd675fcde|167|rds|local|vector|||8.547|| -iTRAQI_sa1_map|stem|4919f2c5defb5a00|2303afe4478a8ce8|fd2dfc187d8ebb85|-505862102||t19889.2028059872s|24d52ebf1535bba2|123|rds|local|vector|||6.25|| -iTRAQI_sa2_map|stem|923091d6dba5c13d|b1c883ef38a95d1f|315e4b203db54e2e|-544962212||t19889.2026461592s|24d52ebf1535bba2|123|rds|local|vector|||3.594|| -iTRAQI_tables|stem|dbe30ae6c7af123c|d57bd319170d08e2|243d6320725335b7|-130480019||t19889.210002604s|a2c8acb31b0e29cd|806|rds|local|vector|||2.438|| +iTRAQI_legends|stem|f653617587a60336|2eb810a937c63cee|29cd3bc59e1a7e94|-1228347186||t19889.2405467344s|af2f698bb96276c8|148|rds|local|vector|||3.531|| +itraqi_list|stem|52e26d87581372b8|b0bc70d7b56caee2|7d885c613f99a996|-1855879146||t19889.2400875673s|22357292cb71aa7e|25450950|rds|local|vector|||2.328|| +iTRAQI_rehab_maps|stem|e1261ccb6bf56ab6|fd02f3040beca726|6700e89c3189f5f1|140306304||t19889.2405041936s|3c9f22cdd675fcde|167|rds|local|vector|||7|| +iTRAQI_sa1_map|stem|4919f2c5defb5a00|2303afe4478a8ce8|81fc8284ad0c22d5|-505862102||t19889.240598575s|24d52ebf1535bba2|123|rds|local|vector|||3.547|| +iTRAQI_sa2_map|stem|923091d6dba5c13d|b1c883ef38a95d1f|65de865d3862a6a8|-544962212||t19889.2405257879s|24d52ebf1535bba2|123|rds|local|vector|||3.203|| +iTRAQI_tables|stem|dbe30ae6c7af123c|d57bd319170d08e2|624f07f5e21b9c64|-130480019||t19889.2405378269s|a2c8acb31b0e29cd|806|rds|local|vector|||1.719|| l_all_drive_times|stem|863290ab751782f0|322c9834645b4160|7cdfb0cf9ae7937a|1979637785||t19727.699503603s|19a7a986c137792d|69482|rds|local|vector|||0.625|| l_itraqi_breaks|stem|1c29f7ad4e7e585f|321d97320e85dc90|ef46db3751d8e999|-472980907||t19866.4660676659s|094cdf8ee71e1e88|135|rds|local|vector|||1.828|| l_remoteness_dlist|stem|fd88b2e32b53b89e|7505d2c62235815e|aecfc931207396ae|1034374804||t19784.3035604944s|83a591c88582aa1c|65324|rds|local|vector|||1.141|| diff --git a/app/app/data/palette_list.rds b/app/app/data/palette_list.rds index 5256fee..1d1c361 100644 Binary files a/app/app/data/palette_list.rds and b/app/app/data/palette_list.rds differ diff --git a/app/app/data/scale_fxs.rds b/app/app/data/scale_fxs.rds index c9df530..d7ddc91 100644 Binary files a/app/app/data/scale_fxs.rds and b/app/app/data/scale_fxs.rds differ diff --git a/app/renv/activate.R b/app/renv/activate.R index cb5401f..ec512bd 100644 --- a/app/renv/activate.R +++ b/app/renv/activate.R @@ -1,6 +1,4 @@ - local({ - # the requested version of renv version <- "1.0.3" attr(version, "sha") <- NULL @@ -14,22 +12,25 @@ local({ start <- Sys.time() profile <- tempfile("renv-startup-", fileext = ".Rprof") utils::Rprof(profile) - on.exit({ - utils::Rprof(NULL) - elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L) - writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed))) - writeLines(sprintf("- Profile: %s", profile)) - print(utils::summaryRprof(profile)) - }, add = TRUE) + on.exit( + { + utils::Rprof(NULL) + elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L) + writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed))) + writeLines(sprintf("- Profile: %s", profile)) + print(utils::summaryRprof(profile)) + }, + add = TRUE + ) } # figure out whether the autoloader is enabled enabled <- local({ - # first, check config option override <- getOption("renv.config.autoloader.enabled") - if (!is.null(override)) + if (!is.null(override)) { return(override) + } # next, check environment variables # TODO: prefer using the configuration one in the future @@ -41,17 +42,18 @@ local({ for (envvar in envvars) { envval <- Sys.getenv(envvar, unset = NA) - if (!is.na(envval)) + if (!is.na(envval)) { return(tolower(envval) %in% c("true", "t", "1")) + } } # enable by default TRUE - }) - if (!enabled) + if (!enabled) { return(FALSE) + } # avoid recursion if (identical(getOption("renv.autoloader.running"), TRUE)) { @@ -71,53 +73,51 @@ local({ library(utils, lib.loc = .Library) # unload renv if it's already been loaded - if ("renv" %in% loadedNamespaces()) + if ("renv" %in% loadedNamespaces()) { unloadNamespace("renv") + } - # load bootstrap tools + # load bootstrap tools `%||%` <- function(x, y) { if (is.null(x)) y else x } - + catf <- function(fmt, ..., appendLF = TRUE) { - quiet <- getOption("renv.bootstrap.quiet", default = FALSE) - if (quiet) + if (quiet) { return(invisible()) - + } + msg <- sprintf(fmt, ...) cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") - + invisible(msg) - } - + header <- function(label, ..., prefix = "#", suffix = "-", - n = min(getOption("width"), 78)) - { + n = min(getOption("width"), 78)) { label <- sprintf(label, ...) n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L) - if (n <= 0) + if (n <= 0) { return(paste(prefix, label)) - + } + tail <- paste(rep.int(suffix, n), collapse = "") paste0(prefix, " ", label, " ", tail) - } - + startswith <- function(string, prefix) { substring(string, 1, nchar(prefix)) == prefix } - + bootstrap <- function(version, library) { - friendly <- renv_bootstrap_version_friendly(version) section <- header(sprintf("Bootstrapping renv %s", friendly)) catf(section) - + # attempt to download renv catf("- Downloading renv ... ", appendLF = FALSE) withCallingHandlers( @@ -129,7 +129,7 @@ local({ ) catf("OK") on.exit(unlink(tarball), add = TRUE) - + # now attempt to install catf("- Installing renv ... ", appendLF = FALSE) withCallingHandlers( @@ -140,213 +140,207 @@ local({ } ) catf("OK") - + # add empty line to break up bootstrapping from normal output catf("") - + return(invisible()) } - + renv_bootstrap_tests_running <- function() { getOption("renv.tests.running", default = FALSE) } - + renv_bootstrap_repos <- function() { - # get CRAN repository cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") - + # check for repos override repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) if (!is.na(repos)) { - # check for RSPM; if set, use a fallback repository for renv rspm <- Sys.getenv("RSPM", unset = NA) - if (identical(rspm, repos)) + if (identical(rspm, repos)) { repos <- c(RSPM = rspm, CRAN = cran) - + } + return(repos) - } - + # check for lockfile repositories repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) - if (!inherits(repos, "error") && length(repos)) + if (!inherits(repos, "error") && length(repos)) { return(repos) - + } + # retrieve current repos repos <- getOption("repos") - + # ensure @CRAN@ entries are resolved repos[repos == "@CRAN@"] <- cran - + # add in renv.bootstrap.repos if set default <- c(FALLBACK = "https://cloud.r-project.org") extra <- getOption("renv.bootstrap.repos", default = default) repos <- c(repos, extra) - + # remove duplicates that might've snuck in dupes <- duplicated(repos) | duplicated(names(repos)) repos[!dupes] - } - + renv_bootstrap_repos_lockfile <- function() { - lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") - if (!file.exists(lockpath)) + if (!file.exists(lockpath)) { return(NULL) - + } + lockfile <- tryCatch(renv_json_read(lockpath), error = identity) if (inherits(lockfile, "error")) { warning(lockfile) return(NULL) } - + repos <- lockfile$R$Repositories - if (length(repos) == 0) + if (length(repos) == 0) { return(NULL) - + } + keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) names(vals) <- keys - + return(vals) - } - + renv_bootstrap_download <- function(version) { - sha <- attr(version, "sha", exact = TRUE) - + methods <- if (!is.null(sha)) { - # attempting to bootstrap a development version of renv c( function() renv_bootstrap_download_tarball(sha), function() renv_bootstrap_download_github(sha) ) - } else { - # attempting to bootstrap a release version of renv c( function() renv_bootstrap_download_tarball(version), function() renv_bootstrap_download_cran_latest(version), function() renv_bootstrap_download_cran_archive(version) ) - } - + for (method in methods) { path <- tryCatch(method(), error = identity) - if (is.character(path) && file.exists(path)) + if (is.character(path) && file.exists(path)) { return(path) + } } - + stop("All download methods failed") - } - + renv_bootstrap_download_impl <- function(url, destfile) { - mode <- "wb" - + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 fixup <- Sys.info()[["sysname"]] == "Windows" && - substring(url, 1L, 5L) == "file:" - - if (fixup) + substring(url, 1L, 5L) == "file:" + + if (fixup) { mode <- "w+b" - + } + args <- list( url = url, destfile = destfile, mode = mode, quiet = TRUE ) - - if ("headers" %in% names(formals(utils::download.file))) + + if ("headers" %in% names(formals(utils::download.file))) { args$headers <- renv_bootstrap_download_custom_headers(url) - + } + do.call(utils::download.file, args) - } - + renv_bootstrap_download_custom_headers <- function(url) { - headers <- getOption("renv.download.headers") - if (is.null(headers)) + if (is.null(headers)) { return(character()) - - if (!is.function(headers)) + } + + if (!is.function(headers)) { stopf("'renv.download.headers' is not a function") - + } + headers <- headers(url) - if (length(headers) == 0L) + if (length(headers) == 0L) { return(character()) - - if (is.list(headers)) + } + + if (is.list(headers)) { headers <- unlist(headers, recursive = FALSE, use.names = TRUE) - + } + ok <- is.character(headers) && - is.character(names(headers)) && - all(nzchar(names(headers))) - - if (!ok) + is.character(names(headers)) && + all(nzchar(names(headers))) + + if (!ok) { stop("invocation of 'renv.download.headers' did not return a named character vector") - + } + headers - } - + renv_bootstrap_download_cran_latest <- function(version) { - spec <- renv_bootstrap_download_cran_latest_find(version) - type <- spec$type + type <- spec$type repos <- spec$repos - + baseurl <- utils::contrib.url(repos = repos, type = type) - ext <- if (identical(type, "source")) + ext <- if (identical(type, "source")) { ".tar.gz" - else if (Sys.info()[["sysname"]] == "Windows") + } else if (Sys.info()[["sysname"]] == "Windows") { ".zip" - else + } else { ".tgz" + } name <- sprintf("renv_%s%s", version, ext) url <- paste(baseurl, name, sep = "/") - + destfile <- file.path(tempdir(), name) status <- tryCatch( renv_bootstrap_download_impl(url, destfile), condition = identity ) - - if (inherits(status, "condition")) + + if (inherits(status, "condition")) { return(FALSE) - + } + # report success and return destfile - } - + renv_bootstrap_download_cran_latest_find <- function(version) { - # check whether binaries are supported on this system binary <- getOption("renv.bootstrap.binary", default = TRUE) && - !identical(.Platform$pkgType, "source") && - !identical(getOption("pkgType"), "source") && - Sys.info()[["sysname"]] %in% c("Darwin", "Windows") - + !identical(.Platform$pkgType, "source") && + !identical(getOption("pkgType"), "source") && + Sys.info()[["sysname"]] %in% c("Darwin", "Windows") + types <- c(if (binary) "binary", "source") - + # iterate over types + repositories for (type in types) { for (repos in renv_bootstrap_repos()) { - # retrieve package database db <- tryCatch( as.data.frame( @@ -355,89 +349,83 @@ local({ ), error = identity ) - - if (inherits(db, "error")) + + if (inherits(db, "error")) { next - + } + # check for compatible entry entry <- db[db$Package %in% "renv" & db$Version %in% version, ] - if (nrow(entry) == 0) + if (nrow(entry) == 0) { next - + } + # found it; return spec to caller spec <- list(entry = entry, type = type, repos = repos) return(spec) - } } - + # if we got here, we failed to find renv fmt <- "renv %s is not available from your declared package repositories" stop(sprintf(fmt, version)) - } - + renv_bootstrap_download_cran_archive <- function(version) { - name <- sprintf("renv_%s.tar.gz", version) repos <- renv_bootstrap_repos() urls <- file.path(repos, "src/contrib/Archive/renv", name) destfile <- file.path(tempdir(), name) - + for (url in urls) { - status <- tryCatch( renv_bootstrap_download_impl(url, destfile), condition = identity ) - - if (identical(status, 0L)) + + if (identical(status, 0L)) { return(destfile) - + } } - + return(FALSE) - } - + renv_bootstrap_download_tarball <- function(version) { - # if the user has provided the path to a tarball via # an environment variable, then use it tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) - if (is.na(tarball)) + if (is.na(tarball)) { return() - + } + # allow directories if (dir.exists(tarball)) { name <- sprintf("renv_%s.tar.gz", version) tarball <- file.path(tarball, name) } - + # bail if it doesn't exist if (!file.exists(tarball)) { - # let the user know we weren't able to honour their request fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." msg <- sprintf(fmt, tarball) warning(msg) - + # bail return() - } - + catf("- Using local tarball '%s'.", tarball) tarball - } - + renv_bootstrap_download_github <- function(version) { - enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") - if (!identical(enabled, "TRUE")) + if (!identical(enabled, "TRUE")) { return(FALSE) - + } + # prepare download options pat <- Sys.getenv("GITHUB_PAT") if (nzchar(Sys.which("curl")) && nzchar(pat)) { @@ -453,25 +441,25 @@ local({ options(download.file.method = "wget", download.file.extra = extra) on.exit(do.call(base::options, saved), add = TRUE) } - + url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) name <- sprintf("renv_%s.tar.gz", version) destfile <- file.path(tempdir(), name) - + status <- tryCatch( renv_bootstrap_download_impl(url, destfile), condition = identity ) - - if (!identical(status, 0L)) + + if (!identical(status, 0L)) { return(FALSE) - + } + renv_bootstrap_download_augment(destfile) - + return(destfile) - } - + # Add Sha to DESCRIPTION. This is stop gap until #890, after which we # can use renv::install() to fully capture metadata. renv_bootstrap_download_augment <- function(destfile) { @@ -479,13 +467,13 @@ local({ if (is.null(sha)) { return() } - + # Untar tempdir <- tempfile("renv-github-") on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) untar(destfile, exdir = tempdir) pkgdir <- dir(tempdir, full.names = TRUE)[[1]] - + # Modify description desc_path <- file.path(pkgdir, "DESCRIPTION") desc_lines <- readLines(desc_path) @@ -499,170 +487,163 @@ local({ paste("RemoteSha: ", sha) ) writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path) - + # Re-tar local({ old <- setwd(tempdir) on.exit(setwd(old), add = TRUE) - + tar(destfile, compression = "gzip") }) invisible() } - + # Extract the commit hash from a git archive. Git archives include the SHA1 # hash as the comment field of the tarball pax extended header # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html) # For GitHub archives this should be the first header after the default one # (512 byte) header. renv_bootstrap_git_extract_sha1_tar <- function(bundle) { - # open the bundle for reading # We use gzcon for everything because (from ?gzcon) # > Reading from a connection which does not supply a 'gzip' magic # > header is equivalent to reading from the original connection conn <- gzcon(file(bundle, open = "rb", raw = TRUE)) on.exit(close(conn)) - + # The default pax header is 512 bytes long and the first pax extended header # with the comment should be 51 bytes long # `52 comment=` (11 chars) + 40 byte SHA1 hash len <- 0x200 + 0x33 res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len]) - + if (grepl("^52 comment=", res)) { sub("52 comment=", "", res) } else { NULL } } - + renv_bootstrap_install <- function(version, tarball, library) { - # attempt to install it into project library dir.create(library, showWarnings = FALSE, recursive = TRUE) output <- renv_bootstrap_install_impl(library, tarball) - + # check for successful install status <- attr(output, "status") - if (is.null(status) || identical(status, 0L)) + if (is.null(status) || identical(status, 0L)) { return(status) - + } + # an error occurred; report it header <- "installation of renv failed" lines <- paste(rep.int("=", nchar(header)), collapse = "") text <- paste(c(header, lines, output), collapse = "\n") stop(text) - } - + renv_bootstrap_install_impl <- function(library, tarball) { - # invoke using system2 so we can capture and report output bin <- R.home("bin") exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" R <- file.path(bin, exe) - + args <- c( "--vanilla", "CMD", "INSTALL", "--no-multiarch", "-l", shQuote(path.expand(library)), shQuote(path.expand(tarball)) ) - + system2(R, args, stdout = TRUE, stderr = TRUE) - } - + renv_bootstrap_platform_prefix <- function() { - # construct version prefix version <- paste(R.version$major, R.version$minor, sep = ".") prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") - + # include SVN revision for development versions of R # (to avoid sharing platform-specific artefacts with released versions of R) devel <- - identical(R.version[["status"]], "Under development (unstable)") || - identical(R.version[["nickname"]], "Unsuffered Consequences") - - if (devel) + identical(R.version[["status"]], "Under development (unstable)") || + identical(R.version[["nickname"]], "Unsuffered Consequences") + + if (devel) { prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") - + } + # build list of path components components <- c(prefix, R.version$platform) - + # include prefix if provided by user prefix <- renv_bootstrap_platform_prefix_impl() - if (!is.na(prefix) && nzchar(prefix)) + if (!is.na(prefix) && nzchar(prefix)) { components <- c(prefix, components) - + } + # build prefix paste(components, collapse = "/") - } - + renv_bootstrap_platform_prefix_impl <- function() { - # if an explicit prefix has been supplied, use it prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) - if (!is.na(prefix)) + if (!is.na(prefix)) { return(prefix) - + } + # if the user has requested an automatic prefix, generate it auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) - if (auto %in% c("TRUE", "True", "true", "1")) + if (auto %in% c("TRUE", "True", "true", "1")) { return(renv_bootstrap_platform_prefix_auto()) - + } + # empty string on failure "" - } - + renv_bootstrap_platform_prefix_auto <- function() { - prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) if (inherits(prefix, "error") || prefix %in% "unknown") { - msg <- paste( "failed to infer current operating system", "please file a bug report at https://github.com/rstudio/renv/issues", sep = "; " ) - + warning(msg) - } - + prefix - } - + renv_bootstrap_platform_os <- function() { - sysinfo <- Sys.info() sysname <- sysinfo[["sysname"]] - + # handle Windows + macOS up front - if (sysname == "Windows") + if (sysname == "Windows") { return("windows") - else if (sysname == "Darwin") + } else if (sysname == "Darwin") { return("macos") - + } + # check for os-release files - for (file in c("/etc/os-release", "/usr/lib/os-release")) - if (file.exists(file)) + for (file in c("/etc/os-release", "/usr/lib/os-release")) { + if (file.exists(file)) { return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) - + } + } + # check for redhat-release files - if (file.exists("/etc/redhat-release")) + if (file.exists("/etc/redhat-release")) { return(renv_bootstrap_platform_os_via_redhat_release()) - + } + "unknown" - } - + renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { - # read /etc/os-release release <- utils::read.table( file = file, @@ -672,13 +653,13 @@ local({ comment.char = "#", stringsAsFactors = FALSE ) - + vars <- as.list(release$Value) names(vars) <- release$Key - + # get os name os <- tolower(sysinfo[["sysname"]]) - + # read id id <- "unknown" for (field in c("ID", "ID_LIKE")) { @@ -687,7 +668,7 @@ local({ break } } - + # read version version <- "unknown" for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { @@ -696,91 +677,84 @@ local({ break } } - + # join together paste(c(os, id, version), collapse = "-") - } - + renv_bootstrap_platform_os_via_redhat_release <- function() { - # read /etc/redhat-release contents <- readLines("/etc/redhat-release", warn = FALSE) - + # infer id - id <- if (grepl("centos", contents, ignore.case = TRUE)) + id <- if (grepl("centos", contents, ignore.case = TRUE)) { "centos" - else if (grepl("redhat", contents, ignore.case = TRUE)) + } else if (grepl("redhat", contents, ignore.case = TRUE)) { "redhat" - else + } else { "unknown" - + } + # try to find a version component (very hacky) version <- "unknown" - + parts <- strsplit(contents, "[[:space:]]")[[1L]] for (part in parts) { - nv <- tryCatch(numeric_version(part), error = identity) - if (inherits(nv, "error")) + if (inherits(nv, "error")) { next - + } + version <- nv[1, 1] break - } - + paste(c("linux", id, version), collapse = "-") - } - + renv_bootstrap_library_root_name <- function(project) { - # use project name as-is if requested asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") - if (asis) + if (asis) { return(basename(project)) - + } + # otherwise, disambiguate based on project's path id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) paste(basename(project), id, sep = "-") - } - + renv_bootstrap_library_root <- function(project) { - prefix <- renv_bootstrap_profile_prefix() - + path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) - if (!is.na(path)) + if (!is.na(path)) { return(paste(c(path, prefix), collapse = "/")) - + } + path <- renv_bootstrap_library_root_impl(project) if (!is.null(path)) { name <- renv_bootstrap_library_root_name(project) return(paste(c(path, prefix, name), collapse = "/")) } - + renv_bootstrap_paths_renv("library", project = project) - } - + renv_bootstrap_library_root_impl <- function(project) { - root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) - if (!is.na(root)) + if (!is.na(root)) { return(root) - + } + type <- renv_bootstrap_project_type(project) if (identical(type, "package")) { userdir <- renv_bootstrap_user_dir() return(file.path(userdir, "library")) } - } - + renv_bootstrap_validate_version <- function(version, description = NULL) { - # resolve description file # # avoid passing lib.loc to `packageDescription()` below, since R will @@ -788,17 +762,19 @@ local({ # this function should only be called after 'renv' is loaded # https://github.com/rstudio/renv/issues/1625 description <- description %||% packageDescription("renv") - + # check whether requested version 'version' matches loaded version of renv sha <- attr(version, "sha", exact = TRUE) - valid <- if (!is.null(sha)) + valid <- if (!is.null(sha)) { renv_bootstrap_validate_version_dev(sha, description) - else + } else { renv_bootstrap_validate_version_release(version, description) - - if (valid) + } + + if (valid) { return(TRUE) - + } + # the loaded version of renv doesn't match the requested version; # give the user instructions on how to proceed remote <- if (!is.null(description[["RemoteSha"]])) { @@ -806,13 +782,13 @@ local({ } else { paste("renv", description[["Version"]], sep = "@") } - + # display both loaded version + sha if available friendly <- renv_bootstrap_version_friendly( version = description[["Version"]], sha = description[["RemoteSha"]] ) - + fmt <- paste( "renv %1$s was loaded from project library, but this project is configured to use renv %2$s.", "- Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.", @@ -820,116 +796,115 @@ local({ sep = "\n" ) catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) - + FALSE - } - + renv_bootstrap_validate_version_dev <- function(version, description) { expected <- description[["RemoteSha"]] is.character(expected) && startswith(expected, version) } - + renv_bootstrap_validate_version_release <- function(version, description) { expected <- description[["Version"]] is.character(expected) && identical(expected, version) } - + renv_bootstrap_hash_text <- function(text) { - hashfile <- tempfile("renv-hash-") on.exit(unlink(hashfile), add = TRUE) - + writeLines(text, con = hashfile) tools::md5sum(hashfile) - } - + renv_bootstrap_load <- function(project, libpath, version) { - # try to load renv from the project library - if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) + if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { return(FALSE) - + } + # warn if the version of renv loaded does not match renv_bootstrap_validate_version(version) - + # execute renv load hooks, if any hooks <- getHook("renv::autoload") - for (hook in hooks) - if (is.function(hook)) + for (hook in hooks) { + if (is.function(hook)) { tryCatch(hook(), error = warnify) - + } + } + # load the project renv::load(project) - + TRUE - } - + renv_bootstrap_profile_load <- function(project) { - # if RENV_PROFILE is already set, just use that profile <- Sys.getenv("RENV_PROFILE", unset = NA) - if (!is.na(profile) && nzchar(profile)) + if (!is.na(profile) && nzchar(profile)) { return(profile) - + } + # check for a profile file (nothing to do if it doesn't exist) path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) - if (!file.exists(path)) + if (!file.exists(path)) { return(NULL) - + } + # read the profile, and set it if it exists contents <- readLines(path, warn = FALSE) - if (length(contents) == 0L) + if (length(contents) == 0L) { return(NULL) - + } + # set RENV_PROFILE profile <- contents[[1L]] - if (!profile %in% c("", "default")) + if (!profile %in% c("", "default")) { Sys.setenv(RENV_PROFILE = profile) - + } + profile - } - + renv_bootstrap_profile_prefix <- function() { profile <- renv_bootstrap_profile_get() - if (!is.null(profile)) + if (!is.null(profile)) { return(file.path("profiles", profile, "renv")) + } } - + renv_bootstrap_profile_get <- function() { profile <- Sys.getenv("RENV_PROFILE", unset = "") renv_bootstrap_profile_normalize(profile) } - + renv_bootstrap_profile_set <- function(profile) { profile <- renv_bootstrap_profile_normalize(profile) - if (is.null(profile)) + if (is.null(profile)) { Sys.unsetenv("RENV_PROFILE") - else + } else { Sys.setenv(RENV_PROFILE = profile) + } } - + renv_bootstrap_profile_normalize <- function(profile) { - - if (is.null(profile) || profile %in% c("", "default")) + if (is.null(profile) || profile %in% c("", "default")) { return(NULL) - + } + profile - } - + renv_bootstrap_path_absolute <- function(path) { - substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( substr(path, 1L, 1L) %in% c(letters, LETTERS) && - substr(path, 2L, 3L) %in% c(":/", ":\\") + substr(path, 2L, 3L) %in% c(":/", ":\\") ) - } - + renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") root <- if (renv_bootstrap_path_absolute(renv)) NULL else project @@ -937,168 +912,168 @@ local({ components <- c(root, renv, prefix, ...) paste(components, collapse = "/") } - + renv_bootstrap_project_type <- function(path) { - descpath <- file.path(path, "DESCRIPTION") - if (!file.exists(descpath)) + if (!file.exists(descpath)) { return("unknown") - + } + desc <- tryCatch( read.dcf(descpath, all = TRUE), error = identity ) - - if (inherits(desc, "error")) + + if (inherits(desc, "error")) { return("unknown") - + } + type <- desc$Type - if (!is.null(type)) + if (!is.null(type)) { return(tolower(type)) - + } + package <- desc$Package - if (!is.null(package)) + if (!is.null(package)) { return("package") - + } + "unknown" - } - + renv_bootstrap_user_dir <- function() { dir <- renv_bootstrap_user_dir_impl() path.expand(chartr("\\", "/", dir)) } - + renv_bootstrap_user_dir_impl <- function() { - # use local override if set override <- getOption("renv.userdir.override") - if (!is.null(override)) + if (!is.null(override)) { return(override) - + } + # use R_user_dir if available tools <- asNamespace("tools") - if (is.function(tools$R_user_dir)) + if (is.function(tools$R_user_dir)) { return(tools$R_user_dir("renv", "cache")) - + } + # try using our own backfill for older versions of R envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") for (envvar in envvars) { root <- Sys.getenv(envvar, unset = NA) - if (!is.na(root)) + if (!is.na(root)) { return(file.path(root, "R/renv")) + } } - + # use platform-specific default fallbacks - if (Sys.info()[["sysname"]] == "Windows") + if (Sys.info()[["sysname"]] == "Windows") { file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") - else if (Sys.info()[["sysname"]] == "Darwin") + } else if (Sys.info()[["sysname"]] == "Darwin") { "~/Library/Caches/org.R-project.R/R/renv" - else + } else { "~/.cache/R/renv" - + } } - + renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) { sha <- sha %||% attr(version, "sha", exact = TRUE) parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L))) paste(parts, collapse = "") } - + renv_bootstrap_exec <- function(project, libpath, version) { - if (!renv_bootstrap_load(project, libpath, version)) + if (!renv_bootstrap_load(project, libpath, version)) { renv_bootstrap_run(version, libpath) + } } - + renv_bootstrap_run <- function(version, libpath) { - # perform bootstrap bootstrap(version, libpath) - + # exit early if we're just testing bootstrap - if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) + if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) { return(TRUE) - + } + # try again to load if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { return(renv::load(project = getwd())) } - + # failed to download or load renv; warn the user msg <- c( "Failed to find an renv installation: the project will not be loaded.", "Use `renv::activate()` to re-initialize the project." ) - + warning(paste(msg, collapse = "\n"), call. = FALSE) - } - + renv_json_read <- function(file = NULL, text = NULL) { - jlerr <- NULL - + # if jsonlite is loaded, use that instead if ("jsonlite" %in% loadedNamespaces()) { - json <- catch(renv_json_read_jsonlite(file, text)) - if (!inherits(json, "error")) + if (!inherits(json, "error")) { return(json) - + } + jlerr <- json - } - + # otherwise, fall back to the default JSON reader json <- catch(renv_json_read_default(file, text)) - if (!inherits(json, "error")) + if (!inherits(json, "error")) { return(json) - + } + # report an error - if (!is.null(jlerr)) + if (!is.null(jlerr)) { stop(jlerr) - else + } else { stop(json) - + } } - + renv_json_read_jsonlite <- function(file = NULL, text = NULL) { text <- paste(text %||% read(file), collapse = "\n") jsonlite::fromJSON(txt = text, simplifyVector = FALSE) } - + renv_json_read_default <- function(file = NULL, text = NULL) { - # find strings in the JSON text <- paste(text %||% read(file), collapse = "\n") pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' locs <- gregexpr(pattern, text, perl = TRUE)[[1]] - + # if any are found, replace them with placeholders replaced <- text strings <- character() replacements <- character() - + if (!identical(c(locs), -1L)) { - # get the string values starts <- locs ends <- locs + attr(locs, "match.length") - 1L strings <- substring(text, starts, ends) - + # only keep those requiring escaping strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) - + # compute replacements replacements <- sprintf('"\032%i\032"', seq_along(strings)) - + # replace the strings mapply(function(string, replacement) { replaced <<- sub(string, replacement, replaced, fixed = TRUE) }, strings, replacements) - } - + # transform the JSON into something the R parser understands transformed <- replaced transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) @@ -1106,58 +1081,57 @@ local({ transformed <- gsub("[]}]", ")", transformed, perl = TRUE) transformed <- gsub(":", "=", transformed, fixed = TRUE) text <- paste(transformed, collapse = "\n") - + # parse it json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] - + # construct map between source strings, replaced strings map <- as.character(parse(text = strings)) names(map) <- as.character(parse(text = replacements)) - + # convert to list map <- as.list(map) - + # remap strings in object remapped <- renv_json_remap(json, map) - + # evaluate eval(remapped, envir = baseenv()) - } - + renv_json_remap <- function(json, map) { - # fix names if (!is.null(names(json))) { lhs <- match(names(json), names(map), nomatch = 0L) rhs <- match(names(map), names(json), nomatch = 0L) names(json)[rhs] <- map[lhs] } - + # fix values - if (is.character(json)) + if (is.character(json)) { return(map[[json]] %||% json) - + } + # handle true, false, null if (is.name(json)) { text <- as.character(json) - if (text == "true") + if (text == "true") { return(TRUE) - else if (text == "false") + } else if (text == "false") { return(FALSE) - else if (text == "null") + } else if (text == "null") { return(NULL) + } } - + # recurse if (is.recursive(json)) { for (i in seq_along(json)) { json[i] <- list(renv_json_remap(json[[i]], map)) } } - + json - } # load the renv profile, if any @@ -1176,5 +1150,4 @@ local({ renv_bootstrap_exec(project, libpath, version) invisible() - }) diff --git a/output/figures/iTRAQI-SA1s.jpeg b/output/figures/iTRAQI-SA1s.jpeg index 1e2ae52..c81aa93 100644 Binary files a/output/figures/iTRAQI-SA1s.jpeg and b/output/figures/iTRAQI-SA1s.jpeg differ diff --git a/output/figures/iTRAQI-SA2s.jpeg b/output/figures/iTRAQI-SA2s.jpeg index e9dc103..39dca3c 100644 Binary files a/output/figures/iTRAQI-SA2s.jpeg and b/output/figures/iTRAQI-SA2s.jpeg differ diff --git a/output/figures/index_legend.jpeg b/output/figures/index_legend.jpeg index a6bf53e..ae3780f 100644 Binary files a/output/figures/index_legend.jpeg and b/output/figures/index_legend.jpeg differ diff --git a/output/tables/iTRAQI-palette.docx b/output/tables/iTRAQI-palette.docx index 298db20..f3c87d9 100644 Binary files a/output/tables/iTRAQI-palette.docx and b/output/tables/iTRAQI-palette.docx differ