From 82b8db7f84ea5bc591fc1d365956a72ca6ba2787 Mon Sep 17 00:00:00 2001 From: Jared Knowles Date: Fri, 9 Aug 2024 15:05:59 -0400 Subject: [PATCH 1/4] fix proportion ci calc and theme --- Dockerfile | 54 +++++++-------- Jenkinsfile | 120 +++++++++++++++++----------------- Makefile | 52 +++++++-------- NAMESPACE | 96 +++++++++++++-------------- R/join_utilities.R | 96 +++++++++++++-------------- R/prop_conf.R | 70 ++++++++++++++++++++ R/theme.R | 8 +-- R/utils.R | 27 -------- man/add_logo.Rd | 42 ++++++------ man/add_logo_ga.Rd | 72 ++++++++++---------- man/countDots.Rd | 34 +++++----- man/get_png.Rd | 34 +++++----- man/grade_level_to_num.Rd | 40 ++++++------ man/measure_caption.Rd | 44 ++++++------- man/race_short_names.Rd | 40 ++++++------ man/star_subs.Rd | 56 ++++++++-------- tests/testthat/test_joins.R | 30 ++++----- tests/testthat/test_propint.R | 2 + 18 files changed, 481 insertions(+), 436 deletions(-) create mode 100644 R/prop_conf.R create mode 100644 tests/testthat/test_propint.R diff --git a/Dockerfile b/Dockerfile index 2b7d7d7..02925db 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,27 +1,27 @@ -# [Choice] R version: 4, 4.2, 4.1, 4.0 -ARG VARIANT=4.2 -# [Choice] Base image. Minimal (r-ver), tidyverse installed (tidyverse), or full image (binder): rocker/r-ver, rocker/tidyverse, rocker/binder -ARG BASE_IMAGE=rocker/r-ver -FROM ${BASE_IMAGE}:${VARIANT} - - -RUN apt-get update && apt-get install -y --no-install-recommends \ - sudo \ - libcurl4-gnutls-dev \ - libxml2-dev \ - libcairo2-dev \ - libxt-dev \ - libjpeg-dev \ - libpng-dev \ - openjdk-11-jdk \ - libssl-dev \ - libssh2-1-dev \ - libudunits2-dev \ - libgdal-dev \ - libgeos-dev \ - libproj-dev \ - && rm -rf /var/lib/apt/lists/* \ - && mkdir -p /var/lib/shiny-server/bookmarks/shiny - - -RUN install2.r ggplot2 jpeg png stringr gridExtra grid testthat covr tidycensus stringdist +# [Choice] R version: 4, 4.2, 4.1, 4.0 +ARG VARIANT=4.2 +# [Choice] Base image. Minimal (r-ver), tidyverse installed (tidyverse), or full image (binder): rocker/r-ver, rocker/tidyverse, rocker/binder +ARG BASE_IMAGE=rocker/r-ver +FROM ${BASE_IMAGE}:${VARIANT} + + +RUN apt-get update && apt-get install -y --no-install-recommends \ + sudo \ + libcurl4-gnutls-dev \ + libxml2-dev \ + libcairo2-dev \ + libxt-dev \ + libjpeg-dev \ + libpng-dev \ + openjdk-11-jdk \ + libssl-dev \ + libssh2-1-dev \ + libudunits2-dev \ + libgdal-dev \ + libgeos-dev \ + libproj-dev \ + && rm -rf /var/lib/apt/lists/* \ + && mkdir -p /var/lib/shiny-server/bookmarks/shiny + + +RUN install2.r ggplot2 jpeg png stringr gridExtra grid testthat covr tidycensus stringdist diff --git a/Jenkinsfile b/Jenkinsfile index 09df590..675b5f2 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -1,60 +1,60 @@ -pipeline { - agent { - dockerfile true - } - stages { - stage('Docker setup') { - steps { - sh ''' - R --version - java --version - ''' - } - - } - stage('Build and test') { - stages { - stage("Build package") { - steps { - sh ''' - R CMD build . - ''' - } - } - stage('Check') { - steps { - sh ''' - R CMD check --no-manual civilytics_0.1.0.tar.gz - ''' - - sh ''' - R CMD INSTALL civilytics_0.1.0.tar.gz - ''' - } - } - stage('testthat'){ - steps { - sh ''' - R -e 'testthat::test_local(".")' - ''' - } - } - stage('test coverage') { - steps { - sh ''' - R -e 'covr::package_coverage(".")' - ''' - } - } - stage('Clean') { - steps { - - sh ''' - rm -rf civilytics_0.1.0.tar.gz civilytics.Rcheck - ''' - } - } - } -} -} -} +pipeline { + agent { + dockerfile true + } + stages { + stage('Docker setup') { + steps { + sh ''' + R --version + java --version + ''' + } + + } + stage('Build and test') { + stages { + stage("Build package") { + steps { + sh ''' + R CMD build . + ''' + } + } + stage('Check') { + steps { + sh ''' + R CMD check --no-manual civilytics_0.1.0.tar.gz + ''' + + sh ''' + R CMD INSTALL civilytics_0.1.0.tar.gz + ''' + } + } + stage('testthat'){ + steps { + sh ''' + R -e 'testthat::test_local(".")' + ''' + } + } + stage('test coverage') { + steps { + sh ''' + R -e 'covr::package_coverage(".")' + ''' + } + } + stage('Clean') { + steps { + + sh ''' + rm -rf civilytics_0.1.0.tar.gz civilytics.Rcheck + ''' + } + } + } +} +} +} diff --git a/Makefile b/Makefile index 664fc9b..f2258a1 100644 --- a/Makefile +++ b/Makefile @@ -1,26 +1,26 @@ -# h/t to @jimhester and @yihui for this parse block: -# https://github.com/yihui/knitr/blob/dc5ead7bcfc0ebd2789fe99c527c7d91afb3de4a/Makefile#L1-L4 -# Note the portability change as suggested in the manual: -# https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Writing-portable-packages -PKGNAME = `sed -n "s/Package: *\([^ ]*\)/\1/p" DESCRIPTION` -PKGVERS = `sed -n "s/Version: *\([^ ]*\)/\1/p" DESCRIPTION` - - -all: check - -build: install_deps - R CMD build . - -check: build - R CMD check --no-manual $(PKGNAME)_$(PKGVERS).tar.gz - -install_deps: - Rscript \ - -e 'if (!requireNamespace("remotes")) install.packages("remotes")' \ - -e 'remotes::install_deps(dependencies = TRUE)' - -install: build - R CMD INSTALL $(PKGNAME)_$(PKGVERS).tar.gz - -clean: - @rm -rf $(PKGNAME)_$(PKGVERS).tar.gz $(PKGNAME).Rcheck +# h/t to @jimhester and @yihui for this parse block: +# https://github.com/yihui/knitr/blob/dc5ead7bcfc0ebd2789fe99c527c7d91afb3de4a/Makefile#L1-L4 +# Note the portability change as suggested in the manual: +# https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Writing-portable-packages +PKGNAME = `sed -n "s/Package: *\([^ ]*\)/\1/p" DESCRIPTION` +PKGVERS = `sed -n "s/Version: *\([^ ]*\)/\1/p" DESCRIPTION` + + +all: check + +build: install_deps + R CMD build . + +check: build + R CMD check --no-manual $(PKGNAME)_$(PKGVERS).tar.gz + +install_deps: + Rscript \ + -e 'if (!requireNamespace("remotes")) install.packages("remotes")' \ + -e 'remotes::install_deps(dependencies = TRUE)' + +install: build + R CMD INSTALL $(PKGNAME)_$(PKGVERS).tar.gz + +clean: + @rm -rf $(PKGNAME)_$(PKGVERS).tar.gz $(PKGNAME).Rcheck diff --git a/NAMESPACE b/NAMESPACE index 133c5c1..49aafd7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,48 +1,48 @@ -# Generated by roxygen2: do not edit by hand - -export(add_logo) -export(add_logo_ga) -export(countCleanr) -export(countDots) -export(countNA) -export(dbSafeNames) -export(findDots) -export(get_fips) -export(get_png) -export(get_stabbr) -export(grade_level_to_num) -export(has_caption) -export(make_logo_grob) -export(match_test) -export(measure_caption) -export(na_sum) -export(na_zero) -export(nvals) -export(outersect) -export(perturb_count) -export(plot_jpeg) -export(postcode_lookup) -export(pretty_count) -export(pretty_per) -export(race_short_names) -export(random_round) -export(safe_max) -export(safe_ratio) -export(simpleCap) -export(star_subs) -export(theme_civilytics) -export(z_gap_test) -export(z_univariate) -import(ggplot2) -import(tidycensus) -importFrom(ggplot2,theme) -importFrom(graphics,plot) -importFrom(graphics,rasterImage) -importFrom(grid,grid.draw) -importFrom(grid,rasterGrob) -importFrom(gridExtra,arrangeGrob) -importFrom(jpeg,readJPEG) -importFrom(png,readPNG) -importFrom(stats,runif) -importFrom(stringdist,stringsim) -importFrom(stringr,str_count) +# Generated by roxygen2: do not edit by hand + +export(add_logo) +export(add_logo_ga) +export(countCleanr) +export(countDots) +export(countNA) +export(dbSafeNames) +export(findDots) +export(get_fips) +export(get_png) +export(get_stabbr) +export(grade_level_to_num) +export(has_caption) +export(make_logo_grob) +export(match_test) +export(measure_caption) +export(na_sum) +export(na_zero) +export(nvals) +export(outersect) +export(perturb_count) +export(plot_jpeg) +export(postcode_lookup) +export(pretty_count) +export(pretty_per) +export(race_short_names) +export(random_round) +export(safe_max) +export(safe_ratio) +export(simpleCap) +export(star_subs) +export(theme_civilytics) +export(z_gap_test) +export(z_univariate) +import(ggplot2) +import(tidycensus) +importFrom(ggplot2,theme) +importFrom(graphics,plot) +importFrom(graphics,rasterImage) +importFrom(grid,grid.draw) +importFrom(grid,rasterGrob) +importFrom(gridExtra,arrangeGrob) +importFrom(jpeg,readJPEG) +importFrom(png,readPNG) +importFrom(stats,runif) +importFrom(stringdist,stringsim) +importFrom(stringr,str_count) diff --git a/R/join_utilities.R b/R/join_utilities.R index e0bab71..62cfc8a 100644 --- a/R/join_utilities.R +++ b/R/join_utilities.R @@ -1,48 +1,48 @@ -# Join utilities -#' Test the join between two sets of identifiers -#' -#' @param x a vector of identifiers to check against y -#' @param y a vector of identifiers to check against x -#' @param distinct logical, should duplicate values of x and y be removed before testing -#' -#' @return nothing, print a summary of match statistics to the console -#' @export -#' -#' @examples -#' x <- LETTERS -#' y <- c(letters, LETTERS) -#' match_test(x, y) -match_test <- function(x, y, distinct = TRUE) { - if (distinct) { - x <- unique(x) - y <- unique(y) - cat("**** Distinct Matches ****") - cat("\n") - - } - - # TODO: DO not report 100% if there is even 1 mismatch - - xiny <- sum(x %in% y) - total_x <- length(x) - - yinx <- sum(y %in% x) - total_y <- length(y) - - cat("**** Match Summary ****") - cat("\n") - cat("X in Y") - cat("\n") - cat(paste0("Of the ", total_x, " X values, ", xiny, " (", - 100*round(xiny/total_x, 2), "%) were matched.")) - cat("\n") - cat("********************************************") - cat("\n") - cat("Y in X") - cat("\n") - cat(paste0("Of the ", total_y, " Y values, ", yinx, " (", - 100*round(yinx/total_y, 2), "%) were matched.")) - cat("\n") - cat("******************************************") - -} +# Join utilities +#' Test the join between two sets of identifiers +#' +#' @param x a vector of identifiers to check against y +#' @param y a vector of identifiers to check against x +#' @param distinct logical, should duplicate values of x and y be removed before testing +#' +#' @return nothing, print a summary of match statistics to the console +#' @export +#' +#' @examples +#' x <- LETTERS +#' y <- c(letters, LETTERS) +#' match_test(x, y) +match_test <- function(x, y, distinct = TRUE) { + if (distinct) { + x <- unique(x) + y <- unique(y) + cat("**** Distinct Matches ****") + cat("\n") + + } + + # TODO: DO not report 100% if there is even 1 mismatch + + xiny <- sum(x %in% y) + total_x <- length(x) + + yinx <- sum(y %in% x) + total_y <- length(y) + + cat("**** Match Summary ****") + cat("\n") + cat("X in Y") + cat("\n") + cat(paste0("Of the ", total_x, " X values, ", xiny, " (", + 100*round(xiny/total_x, 2), "%) were matched.")) + cat("\n") + cat("********************************************") + cat("\n") + cat("Y in X") + cat("\n") + cat(paste0("Of the ", total_y, " Y values, ", yinx, " (", + 100*round(yinx/total_y, 2), "%) were matched.")) + cat("\n") + cat("******************************************") + +} diff --git a/R/prop_conf.R b/R/prop_conf.R new file mode 100644 index 0000000..6287f2d --- /dev/null +++ b/R/prop_conf.R @@ -0,0 +1,70 @@ + + +# https://github.com/cran/binom/blob/master/R/binom.confint.R +# Consider importing and crediting this code ^^ +# https://towardsdatascience.com/five-confidence-intervals-for-proportions-that-you-should-know-about-7ff5484c024f +# https://andrewpwheeler.com/2020/11/30/confidence-intervals-around-proportions/ +#' Get a simple Clopper Pearson interval +#' +#' @param num +#' @param den +#' @param confint +#' +#' @return +#' @export +#' +#' @examples +clopper_pearson <- function(num, den, confint = 0.95) { + # Same results as binom.test in base R + quant <- (1 - confint) / 2 + low <- qbeta(quant, num, den-num+1) + hi <- qbeta(1-quant, num+1, den-num) + obs <- num/den + return(c("low" = low, "observed" = obs,"high" = hi)) +} + + +# TODO consider making a vectorized version +# z_gap_test_v <- Vectorize(z_gap_test, +# SIMPLIFY = TRUE)# we only want to return a scalar + + +#z_gap_test(a_prop = 0.051, a_count = 2000, b_prop = 0.11, b_count = 100) + + +#' Calculate a univariate z score by comparing to a population +#' +#' @param unit_prop proportion for the group we are comparing +#' @param global_prop the global proportion +#' @param unit_denom the population size for the group we are comparing +#' +#' @return a z-score +#' @export +#' +#' @examples +#' z_univariate(unit_prop = 0.13, global_prop = 0.11, unit_denom = 2500) +z_univariate <- function(unit_prop, global_prop, unit_denom) { + num <- unit_prop - global_prop + denom <- sqrt( + (global_prop * (1-global_prop))/unit_denom + ) + z = num / denom + return(z) + +} + +waldInterval <- function(x, n, conf.level = 0.95){ + p <- x/n + sd <- sqrt(p*((1-p)/n)) + z <- qnorm(c( (1 - conf.level)/2, 1 - (1-conf.level)/2)) #returns the value of thresholds at which conf.level has to be cut at. for 95% CI, this is -1.96 and +1.96 + ci <- p + z*sd + names(ci) <- c('lwr', 'upr') + return(ci) +}#example +#waldInterval(x = 20, n =40) #this will return 0.345 and 0.655 + +agresti_coull_interval <- function(num, den, conf.level) { + num <- num + 2 + den <- den + 4 + +} diff --git a/R/theme.R b/R/theme.R index a43e332..c081feb 100644 --- a/R/theme.R +++ b/R/theme.R @@ -22,14 +22,14 @@ theme_civilytics <- theme( line = element_line( color = "black", - size = line_size, + linewidth = line_size, linetype = 1, lineend = "butt" ), rect = element_rect( fill = NA, color = NA, - size = line_size, + linewidth = line_size, linetype = 1 ), text = element_text( @@ -46,7 +46,7 @@ theme_civilytics <- ), axis.line = element_line( color = "black", - size = line_size, + linewidth = line_size, lineend = "square" ), axis.line.x = NULL, @@ -62,7 +62,7 @@ theme_civilytics <- axis.text.y.right = element_text(margin = margin(l = small_size / 4), hjust = 0), axis.ticks = element_line(color = "black", - size = line_size), + linewidth = line_size), axis.ticks.length = unit(half_line / 2, "pt"), axis.title.x = element_text(margin = margin(t = half_line / 2), diff --git a/R/utils.R b/R/utils.R index 008d449..9853a4b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -308,35 +308,8 @@ z_gap_test <- function(a_prop, a_count, b_prop, b_count) { return(z) } -# TODO consider making a vectorized version -# z_gap_test_v <- Vectorize(z_gap_test, -# SIMPLIFY = TRUE)# we only want to return a scalar -#z_gap_test(a_prop = 0.051, a_count = 2000, b_prop = 0.11, b_count = 100) - - -#' Calculate a univariate z score by comparing to a population -#' -#' @param unit_prop proportion for the group we are comparing -#' @param global_prop the global proportion -#' @param unit_denom the population size for the group we are comparing -#' -#' @return a z-score -#' @export -#' -#' @examples -#' z_univariate(unit_prop = 0.13, global_prop = 0.11, unit_denom = 2500) -z_univariate <- function(unit_prop, global_prop, unit_denom) { - num <- unit_prop - global_prop - denom <- sqrt( - (global_prop * (1-global_prop))/unit_denom - ) - z = num / denom - return(z) - -} - # TODO: Consider vectorizing #z_univariate_v <- Vectorize(z_univariate, SIMPLIFY = TRUE) diff --git a/man/add_logo.Rd b/man/add_logo.Rd index f698eb7..b6cb744 100644 --- a/man/add_logo.Rd +++ b/man/add_logo.Rd @@ -1,21 +1,21 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/logo.R -\name{add_logo} -\alias{add_logo} -\title{Add a logo to a ggplot2 object} -\usage{ -add_logo(plot, logo, margin_param = NULL) -} -\arguments{ -\item{plot}{a ggplot2 grob} - -\item{logo}{a logo grob created by make_logo_grob()} - -\item{margin_param}{a numeric specifying what margin to add or subtract to align the logo} -} -\value{ -a grob with a logo attached to it ready to plot -} -\description{ -Add a logo to a ggplot2 object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logo.R +\name{add_logo} +\alias{add_logo} +\title{Add a logo to a ggplot2 object} +\usage{ +add_logo(plot, logo, margin_param = NULL) +} +\arguments{ +\item{plot}{a ggplot2 grob} + +\item{logo}{a logo grob created by make_logo_grob()} + +\item{margin_param}{a numeric specifying what margin to add or subtract to align the logo} +} +\value{ +a grob with a logo attached to it ready to plot +} +\description{ +Add a logo to a ggplot2 object +} diff --git a/man/add_logo_ga.Rd b/man/add_logo_ga.Rd index fedb5c5..29bb7de 100644 --- a/man/add_logo_ga.Rd +++ b/man/add_logo_ga.Rd @@ -1,36 +1,36 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/logo.R -\name{add_logo_ga} -\alias{add_logo_ga} -\title{Add a logo to a ggplot2 object} -\usage{ -add_logo_ga(plot_list, logo, nrow = 1, widths = NULL, margin_param = NULL) -} -\arguments{ -\item{plot_list}{a list containing ggplot2 objects} - -\item{logo}{a grob containing the logo created with `make_logo_grob`} - -\item{nrow}{an integer, default = 1, for the number of rows to align the plots in} - -\item{widths}{an optional vector the same length as plot_list with the widths for each plot} - -\item{margin_param}{a number giving the adjustment up or down to help manually align logo and captions} -} -\value{ -a grid object -} -\description{ -Add a logo to a ggplot2 object -} -\note{ -The resulting object needs to be drawn to the screen using grid.draw() -} -\examples{ -library(ggplot2); library(grid) -tmp_plot <- ggplot(mtcars) + aes(x = hp, y = disp) + geom_point() + theme_civilytics() -tmp_logo <- make_logo_grob() -plot_and_logo <- add_logo(tmp_plot, tmp_logo) -grid.draw(plot_and_logo) -dev.off() -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logo.R +\name{add_logo_ga} +\alias{add_logo_ga} +\title{Add a logo to a ggplot2 object} +\usage{ +add_logo_ga(plot_list, logo, nrow = 1, widths = NULL, margin_param = NULL) +} +\arguments{ +\item{plot_list}{a list containing ggplot2 objects} + +\item{logo}{a grob containing the logo created with `make_logo_grob`} + +\item{nrow}{an integer, default = 1, for the number of rows to align the plots in} + +\item{widths}{an optional vector the same length as plot_list with the widths for each plot} + +\item{margin_param}{a number giving the adjustment up or down to help manually align logo and captions} +} +\value{ +a grid object +} +\description{ +Add a logo to a ggplot2 object +} +\note{ +The resulting object needs to be drawn to the screen using grid.draw() +} +\examples{ +library(ggplot2); library(grid) +tmp_plot <- ggplot(mtcars) + aes(x = hp, y = disp) + geom_point() + theme_civilytics() +tmp_logo <- make_logo_grob() +plot_and_logo <- add_logo(tmp_plot, tmp_logo) +grid.draw(plot_and_logo) +dev.off() +} diff --git a/man/countDots.Rd b/man/countDots.Rd index 7b81d0e..e386b21 100644 --- a/man/countDots.Rd +++ b/man/countDots.Rd @@ -1,17 +1,17 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/db.R -\name{countDots} -\alias{countDots} -\title{Count the number of single period entries in a vector} -\usage{ -countDots(x) -} -\arguments{ -\item{x}{a character vector} -} -\value{ -An integer counting the number of "." occurences in a vector -} -\description{ -Count the number of single period entries in a vector -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/db.R +\name{countDots} +\alias{countDots} +\title{Count the number of single period entries in a vector} +\usage{ +countDots(x) +} +\arguments{ +\item{x}{a character vector} +} +\value{ +An integer counting the number of "." occurences in a vector +} +\description{ +Count the number of single period entries in a vector +} diff --git a/man/get_png.Rd b/man/get_png.Rd index 97988bc..d88f51d 100644 --- a/man/get_png.Rd +++ b/man/get_png.Rd @@ -1,17 +1,17 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/logo.R -\name{get_png} -\alias{get_png} -\title{Plot a PNG file as a rasterGrob for inclusion in ggplot2} -\usage{ -get_png(filename) -} -\arguments{ -\item{filename}{a character with file path to a png file} -} -\value{ -a plotted rasteGrob of a png image -} -\description{ -Plot a PNG file as a rasterGrob for inclusion in ggplot2 -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logo.R +\name{get_png} +\alias{get_png} +\title{Plot a PNG file as a rasterGrob for inclusion in ggplot2} +\usage{ +get_png(filename) +} +\arguments{ +\item{filename}{a character with file path to a png file} +} +\value{ +a plotted rasteGrob of a png image +} +\description{ +Plot a PNG file as a rasterGrob for inclusion in ggplot2 +} diff --git a/man/grade_level_to_num.Rd b/man/grade_level_to_num.Rd index 03a9990..4ec21e2 100644 --- a/man/grade_level_to_num.Rd +++ b/man/grade_level_to_num.Rd @@ -1,20 +1,20 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{grade_level_to_num} -\alias{grade_level_to_num} -\title{Recode grade level from character to numeric} -\usage{ -grade_level_to_num(x) -} -\arguments{ -\item{x}{character description of grade levels from NCES style data} -} -\value{ -a numeric vector -} -\description{ -Recode grade level from character to numeric -} -\examples{ -grade_level_to_num(c("KG", "Pre-K", "12", "10", "09")) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{grade_level_to_num} +\alias{grade_level_to_num} +\title{Recode grade level from character to numeric} +\usage{ +grade_level_to_num(x) +} +\arguments{ +\item{x}{character description of grade levels from NCES style data} +} +\value{ +a numeric vector +} +\description{ +Recode grade level from character to numeric +} +\examples{ +grade_level_to_num(c("KG", "Pre-K", "12", "10", "09")) +} diff --git a/man/measure_caption.Rd b/man/measure_caption.Rd index f38d394..63f37f6 100644 --- a/man/measure_caption.Rd +++ b/man/measure_caption.Rd @@ -1,22 +1,22 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/logo.R -\name{measure_caption} -\alias{measure_caption} -\title{Measure a ggplot2 object caption} -\usage{ -measure_caption(gg) -} -\arguments{ -\item{gg}{a ggplot object} -} -\value{ -a numeric value stating the number of lines to be added or subtracted to align a logo with -the caption -} -\description{ -Measure a ggplot2 object caption -} -\examples{ -p1 <- ggplot2::qplot(mpg, wt, data = mtcars) -measure_caption(p1) # Should equal 1 since no caption is required -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logo.R +\name{measure_caption} +\alias{measure_caption} +\title{Measure a ggplot2 object caption} +\usage{ +measure_caption(gg) +} +\arguments{ +\item{gg}{a ggplot object} +} +\value{ +a numeric value stating the number of lines to be added or subtracted to align a logo with +the caption +} +\description{ +Measure a ggplot2 object caption +} +\examples{ +p1 <- ggplot2::qplot(mpg, wt, data = mtcars) +measure_caption(p1) # Should equal 1 since no caption is required +} diff --git a/man/race_short_names.Rd b/man/race_short_names.Rd index 6215020..21e05fa 100644 --- a/man/race_short_names.Rd +++ b/man/race_short_names.Rd @@ -1,20 +1,20 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{race_short_names} -\alias{race_short_names} -\title{Recode NCES race categories to shorter names} -\usage{ -race_short_names(x) -} -\arguments{ -\item{x}{a character vector with NCES race codes, often from Urban Institute} -} -\value{ -recoded race categories following NCES race codes -} -\description{ -Recode NCES race categories to shorter names -} -\examples{ -race_short_names(c("Black", "Hispanic Or Latino", "Two Or More Races")) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{race_short_names} +\alias{race_short_names} +\title{Recode NCES race categories to shorter names} +\usage{ +race_short_names(x) +} +\arguments{ +\item{x}{a character vector with NCES race codes, often from Urban Institute} +} +\value{ +recoded race categories following NCES race codes +} +\description{ +Recode NCES race categories to shorter names +} +\examples{ +race_short_names(c("Black", "Hispanic Or Latino", "Two Or More Races")) +} diff --git a/man/star_subs.Rd b/man/star_subs.Rd index da8f91d..280f44e 100644 --- a/man/star_subs.Rd +++ b/man/star_subs.Rd @@ -1,28 +1,28 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{star_subs} -\alias{star_subs} -\title{Unsuppress data using sampling} -\usage{ -star_subs(x, replace_char = "*", zeros = 15, max_value = 20) -} -\arguments{ -\item{x}{a vector} - -\item{replace_char}{the character you want to replace in the vector} - -\item{zeros}{the number of zeroes to oversample when replacing replace_char} - -\item{max_value}{the numeric maximum value the replacement for the "*" can be} -} -\value{ -a numeric vector with no characters representing suppressed values -} -\description{ -Unsuppress data using sampling -} -\examples{ -suppr_data <- c("2", "8", "*", "*", "7", "9", "100") -star_subs(suppr_data, zeros = 1, max_value = 10) -star_subs(suppr_data, zeros = 1, max_value = 200) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{star_subs} +\alias{star_subs} +\title{Unsuppress data using sampling} +\usage{ +star_subs(x, replace_char = "*", zeros = 15, max_value = 20) +} +\arguments{ +\item{x}{a vector} + +\item{replace_char}{the character you want to replace in the vector} + +\item{zeros}{the number of zeroes to oversample when replacing replace_char} + +\item{max_value}{the numeric maximum value the replacement for the "*" can be} +} +\value{ +a numeric vector with no characters representing suppressed values +} +\description{ +Unsuppress data using sampling +} +\examples{ +suppr_data <- c("2", "8", "*", "*", "7", "9", "100") +star_subs(suppr_data, zeros = 1, max_value = 10) +star_subs(suppr_data, zeros = 1, max_value = 200) +} diff --git a/tests/testthat/test_joins.R b/tests/testthat/test_joins.R index c8602d0..8e01f2c 100644 --- a/tests/testthat/test_joins.R +++ b/tests/testthat/test_joins.R @@ -1,15 +1,15 @@ - - -#' x <- LETTERS -#' y <- c(letters, LETTERS) -#' match_test(x, y) -#' -#' -context("Test Basic Output for match_test") - -test_that("pretty_per respects rounding", { - x <- LETTERS - y <- c(letters, LETTERS) - testthat::expect_output(match_test(x, y)) - -}) + + +#' x <- LETTERS +#' y <- c(letters, LETTERS) +#' match_test(x, y) +#' +#' +context("Test Basic Output for match_test") + +test_that("pretty_per respects rounding", { + x <- LETTERS + y <- c(letters, LETTERS) + testthat::expect_output(match_test(x, y)) + +}) diff --git a/tests/testthat/test_propint.R b/tests/testthat/test_propint.R new file mode 100644 index 0000000..a684fac --- /dev/null +++ b/tests/testthat/test_propint.R @@ -0,0 +1,2 @@ +# test prop intervals + -- 2.54.0 From f4a4ee85a77cbbdfafb6d7118e2bb15e6ae0fc65 Mon Sep 17 00:00:00 2001 From: Jared Knowles Date: Fri, 9 Aug 2024 15:34:39 -0400 Subject: [PATCH 2/4] fix doco --- DESCRIPTION | 2 +- NAMESPACE | 4 ++++ R/civilytics-package.R | 10 ++++++++++ R/prop_conf.R | 37 ++++++++++++++++++++++++----------- man/agresti_coull_interval.Rd | 21 ++++++++++++++++++++ man/civilytics-package.Rd | 11 +++++++++++ man/clopper_pearson.Rd | 21 ++++++++++++++++++++ man/waldInterval.Rd | 24 +++++++++++++++++++++++ man/z_univariate.Rd | 2 +- 9 files changed, 119 insertions(+), 13 deletions(-) create mode 100644 R/civilytics-package.R create mode 100644 man/agresti_coull_interval.Rd create mode 100644 man/civilytics-package.Rd create mode 100644 man/clopper_pearson.Rd create mode 100644 man/waldInterval.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 63f2300..edd9d9e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,4 +23,4 @@ Encoding: UTF-8 LazyData: true Suggests: testthat -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index 49aafd7..04ba561 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(add_logo) export(add_logo_ga) +export(clopper_pearson) export(countCleanr) export(countDots) export(countNA) @@ -31,6 +32,7 @@ export(safe_ratio) export(simpleCap) export(star_subs) export(theme_civilytics) +export(waldInterval) export(z_gap_test) export(z_univariate) import(ggplot2) @@ -43,6 +45,8 @@ importFrom(grid,rasterGrob) importFrom(gridExtra,arrangeGrob) importFrom(jpeg,readJPEG) importFrom(png,readPNG) +importFrom(stats,qbeta) +importFrom(stats,qnorm) importFrom(stats,runif) importFrom(stringdist,stringsim) importFrom(stringr,str_count) diff --git a/R/civilytics-package.R b/R/civilytics-package.R new file mode 100644 index 0000000..c1dcad6 --- /dev/null +++ b/R/civilytics-package.R @@ -0,0 +1,10 @@ +#' @keywords internal +#' @importFrom stats qbeta +#' @importFrom stats qnorm +"_PACKAGE" + +## usethis namespace: start +## usethis namespace: end +NULL + + diff --git a/R/prop_conf.R b/R/prop_conf.R index 6287f2d..5ac963d 100644 --- a/R/prop_conf.R +++ b/R/prop_conf.R @@ -6,17 +6,15 @@ # https://andrewpwheeler.com/2020/11/30/confidence-intervals-around-proportions/ #' Get a simple Clopper Pearson interval #' -#' @param num -#' @param den -#' @param confint +#' @param num number of successes +#' @param den number of trials +#' @param conf.level default 0.95, set the confidence interval to return #' -#' @return +#' @return three values forming the upper and lower bounds of the confidence region and the true value #' @export -#' -#' @examples -clopper_pearson <- function(num, den, confint = 0.95) { +clopper_pearson <- function(num, den, conf.level = 0.95) { # Same results as binom.test in base R - quant <- (1 - confint) / 2 + quant <- (1 - conf.level) / 2 low <- qbeta(quant, num, den-num+1) hi <- qbeta(1-quant, num+1, den-num) obs <- num/den @@ -24,7 +22,6 @@ clopper_pearson <- function(num, den, confint = 0.95) { } -# TODO consider making a vectorized version # z_gap_test_v <- Vectorize(z_gap_test, # SIMPLIFY = TRUE)# we only want to return a scalar @@ -53,6 +50,17 @@ z_univariate <- function(unit_prop, global_prop, unit_denom) { } +#' Calculate a Wald interval +#' +#' @param x the numerator, number of times the event occurs +#' @param n the denominator, the number of trials +#' @param conf.level default 0.95, set the confidence interval to return +#' +#' @return two values forming the upper and lower bounds of the confidence region +#' @export +#' +#' @examples +#' waldInterval(x = 20, n =40) #this will return 0.345 and 0.655 waldInterval <- function(x, n, conf.level = 0.95){ p <- x/n sd <- sqrt(p*((1-p)/n)) @@ -60,11 +68,18 @@ waldInterval <- function(x, n, conf.level = 0.95){ ci <- p + z*sd names(ci) <- c('lwr', 'upr') return(ci) -}#example -#waldInterval(x = 20, n =40) #this will return 0.345 and 0.655 +} +#' Calculate the Agresti-Coull interval +#' +#' @param num a number of successes +#' @param den a number of trials +#' @param conf.level default 0.95, set the confidence interval to return +#' +#' @return an interval agresti_coull_interval <- function(num, den, conf.level) { num <- num + 2 den <- den + 4 + return(num/den) } diff --git a/man/agresti_coull_interval.Rd b/man/agresti_coull_interval.Rd new file mode 100644 index 0000000..dfd54d5 --- /dev/null +++ b/man/agresti_coull_interval.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_conf.R +\name{agresti_coull_interval} +\alias{agresti_coull_interval} +\title{Calculate the Agresti-Coull interval} +\usage{ +agresti_coull_interval(num, den, conf.level) +} +\arguments{ +\item{num}{a number of successes} + +\item{den}{a number of trials} + +\item{conf.level}{default 0.95, set the confidence interval to return} +} +\value{ +an interval +} +\description{ +Calculate the Agresti-Coull interval +} diff --git a/man/civilytics-package.Rd b/man/civilytics-package.Rd new file mode 100644 index 0000000..97f5880 --- /dev/null +++ b/man/civilytics-package.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/civilytics-package.R +\docType{package} +\name{civilytics-package} +\alias{civilytics} +\alias{civilytics-package} +\title{civilytics: Utilities Functions for Civilytics} +\description{ +House R functions for Civilytics Consulting LLC This package implements a variety of useful functions for creating and branding analyses produced by Civilytics Consulting LLC. +} +\keyword{internal} diff --git a/man/clopper_pearson.Rd b/man/clopper_pearson.Rd new file mode 100644 index 0000000..0fa5b52 --- /dev/null +++ b/man/clopper_pearson.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_conf.R +\name{clopper_pearson} +\alias{clopper_pearson} +\title{Get a simple Clopper Pearson interval} +\usage{ +clopper_pearson(num, den, conf.level = 0.95) +} +\arguments{ +\item{num}{number of successes} + +\item{den}{number of trials} + +\item{conf.level}{default 0.95, set the confidence interval to return} +} +\value{ +three values forming the upper and lower bounds of the confidence region and the true value +} +\description{ +Get a simple Clopper Pearson interval +} diff --git a/man/waldInterval.Rd b/man/waldInterval.Rd new file mode 100644 index 0000000..4d3652d --- /dev/null +++ b/man/waldInterval.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prop_conf.R +\name{waldInterval} +\alias{waldInterval} +\title{Calculate a Wald interval} +\usage{ +waldInterval(x, n, conf.level = 0.95) +} +\arguments{ +\item{x}{the numerator, number of times the event occurs} + +\item{n}{the denominator, the number of trials} + +\item{conf.level}{default 0.95, set the confidence interval to return} +} +\value{ +two values forming the upper and lower bounds of the confidence region +} +\description{ +Calculate a Wald interval +} +\examples{ +waldInterval(x = 20, n =40) #this will return 0.345 and 0.655 +} diff --git a/man/z_univariate.Rd b/man/z_univariate.Rd index 72a2a4b..e197127 100644 --- a/man/z_univariate.Rd +++ b/man/z_univariate.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/prop_conf.R \name{z_univariate} \alias{z_univariate} \title{Calculate a univariate z score by comparing to a population} -- 2.54.0 From 962f8ea6b7efacbabc8497ae4e1f89390c218945 Mon Sep 17 00:00:00 2001 From: Jared Knowles Date: Thu, 19 Sep 2024 14:32:43 -0400 Subject: [PATCH 3/4] add rounding utilities --- DESCRIPTION | 52 +++++++++++++-------------- Jenkinsfile | 6 ++-- NAMESPACE | 3 ++ R/utils.R | 69 ++++++++++++++++++++++++++++++++++++ man/rnh.Rd | 20 +++++++++++ man/round_to_nearest_half.Rd | 22 ++++++++++++ man/trim_max.Rd | 24 +++++++++++++ 7 files changed, 167 insertions(+), 29 deletions(-) create mode 100644 man/rnh.Rd create mode 100644 man/round_to_nearest_half.Rd create mode 100644 man/trim_max.Rd diff --git a/DESCRIPTION b/DESCRIPTION index edd9d9e..c4f2f03 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,26 +1,26 @@ -Package: civilytics -Type: Package -Title: Utilities Functions for Civilytics -Version: 0.1.0 -Author: Jared E. Knowles -Maintainer: Jared E. Knowles -Description: House R functions for Civilytics Consulting LLC - This package implements a variety of useful functions for creating and - branding analyses produced by Civilytics Consulting LLC. -License: LGPL (>= 3) -Depends: - R (>= 2.15.1) -Imports: - ggplot2, - jpeg, - png, - stringr, - gridExtra, - tidycensus, - grid, - stringdist -Encoding: UTF-8 -LazyData: true -Suggests: - testthat -RoxygenNote: 7.3.2 +Package: civilytics +Type: Package +Title: Utilities Functions for Civilytics +Version: 0.2.0 +Author: Jared E. Knowles +Maintainer: Jared E. Knowles +Description: House R functions for Civilytics Consulting LLC + This package implements a variety of useful functions for creating and + branding analyses produced by Civilytics Consulting LLC. +License: LGPL (>= 3) +Depends: + R (>= 2.15.1) +Imports: + ggplot2, + jpeg, + png, + stringr, + gridExtra, + tidycensus, + grid, + stringdist +Encoding: UTF-8 +LazyData: true +Suggests: + testthat +RoxygenNote: 7.3.2 diff --git a/Jenkinsfile b/Jenkinsfile index 675b5f2..c291bcf 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -24,11 +24,11 @@ pipeline { stage('Check') { steps { sh ''' - R CMD check --no-manual civilytics_0.1.0.tar.gz + R CMD check --no-manual civilytics_0.2.0.tar.gz ''' sh ''' - R CMD INSTALL civilytics_0.1.0.tar.gz + R CMD INSTALL civilytics_0.2.0.tar.gz ''' } } @@ -50,7 +50,7 @@ pipeline { steps { sh ''' - rm -rf civilytics_0.1.0.tar.gz civilytics.Rcheck + rm -rf civilytics_0.2.0.tar.gz civilytics.Rcheck ''' } } diff --git a/NAMESPACE b/NAMESPACE index 04ba561..5816444 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,11 +27,14 @@ export(pretty_count) export(pretty_per) export(race_short_names) export(random_round) +export(rnh) +export(round_to_nearest_half) export(safe_max) export(safe_ratio) export(simpleCap) export(star_subs) export(theme_civilytics) +export(trim_max) export(waldInterval) export(z_gap_test) export(z_univariate) diff --git a/R/utils.R b/R/utils.R index 9853a4b..9c3c99c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -376,3 +376,72 @@ safe_ratio <- function(num, denom) { y <- num / denom return(y) } + + + +#' Take the maximum of a number after trimming values +#' +#' @param vec a numeric vector +#' @param n integer, the number of maximum values to trim before taking the maximum +#' +#' @return the highest value after removing the highest n values +#' @export +#' +#' @examples +#' trim_max(c(10, 10, 10, 9, 8, 7), n = 2) +#' trim_max(c(10, 10, 10, 9, 8, 7), n = 3) +#' trim_max(c(10, 10, 10, 9, 8, 7), n = 4) +trim_max <- function(vec, n) { + # Sort vector ascending + sorted_vec <- sort(vec) + end_point <- length(vec) - n + if (end_point <= 0) { + return(1) + } + # Exclude n largest (most extreme) values + filtered_vec <- sorted_vec[(1:(length(vec)-n))] + # Find the maximum value among excluded values if any exist + max_value <- max(filtered_vec, na.rm = TRUE) + return(max_value) +} + + +#' Round values to the nearest 0.5 +#' +#' @param x a numeric vector to round +#' +#' @return a numeric vector with all elements rounded to 0, 0.5, or 1 +#' @export +#' +#' @examples +#' round_to_nearest_half(0.9) +#' round_to_nearest_half(0.7) +#' round_to_nearest_half(0.4) +round_to_nearest_half <- function(x) { + if (x %% 1 == 0) { # If x is already an integer, no change needed + return(as.integer(x)) + } else { + decimal_part <- x - floor(x) + if (decimal_part >= 0.25 & decimal_part < 0.75) { + rounded_x <- floor(x) + 0.5 + } else { + rounded_x <- round(x, 0) + } + return(rounded_x) + } +} + + +#' Round values to the nearest 0.5 +#' +#' @inheritParams round_to_nearest_half +#' +#' @return a numeric vector with all elements rounded to 0, 0.5, or 1 +#' @export +#' +#' @examples +#' rnh(c(0.2, 0.3, 0.4, 0.8, 0.09, 0.9)) +rnh <- function(x) { + tmp <- Vectorize(civilytics::round_to_nearest_half) + tmp(x) +} diff --git a/man/rnh.Rd b/man/rnh.Rd new file mode 100644 index 0000000..8b57ad9 --- /dev/null +++ b/man/rnh.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{rnh} +\alias{rnh} +\title{Round values to the nearest 0.5} +\usage{ +rnh(x) +} +\arguments{ +\item{x}{a numeric vector to round} +} +\value{ +a numeric vector with all elements rounded to 0, 0.5, or 1 +} +\description{ +Round values to the nearest 0.5 +} +\examples{ +rnh(c(0.2, 0.3, 0.4, 0.8, 0.09, 0.9)) +} diff --git a/man/round_to_nearest_half.Rd b/man/round_to_nearest_half.Rd new file mode 100644 index 0000000..4de8075 --- /dev/null +++ b/man/round_to_nearest_half.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{round_to_nearest_half} +\alias{round_to_nearest_half} +\title{Round values to the nearest 0.5} +\usage{ +round_to_nearest_half(x) +} +\arguments{ +\item{x}{a numeric vector to round} +} +\value{ +a numeric vector with all elements rounded to 0, 0.5, or 1 +} +\description{ +Round values to the nearest 0.5 +} +\examples{ +round_to_nearest_half(0.9) +round_to_nearest_half(0.7) +round_to_nearest_half(0.4) +} diff --git a/man/trim_max.Rd b/man/trim_max.Rd new file mode 100644 index 0000000..4dbc7d0 --- /dev/null +++ b/man/trim_max.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{trim_max} +\alias{trim_max} +\title{Take the maximum of a number after trimming values} +\usage{ +trim_max(vec, n) +} +\arguments{ +\item{vec}{a numeric vector} + +\item{n}{integer, the number of maximum values to trim before taking the maximum} +} +\value{ +the highest value after removing the highest n values +} +\description{ +Take the maximum of a number after trimming values +} +\examples{ +trim_max(c(10, 10, 10, 9, 8, 7), n = 2) +trim_max(c(10, 10, 10, 9, 8, 7), n = 3) +trim_max(c(10, 10, 10, 9, 8, 7), n = 4) +} -- 2.54.0 From f3f13fcfe5d9597c96fad2f1c5377ab1d79a1794 Mon Sep 17 00:00:00 2001 From: Jared Knowles Date: Thu, 19 Sep 2024 16:14:30 -0400 Subject: [PATCH 4/4] fix message unicode --- R/utils.R | 2 +- tests/testthat/test_utils.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 9c3c99c..833a2fa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -158,7 +158,7 @@ race_short_names <- function(x) { #' na_sum(x) # 15 na_sum <- function(x) { stopifnot(is.numeric(x)) - message("Taking a sum with missing values equal to 0, be careful! \u1F601") + message("Taking a sum with missing values equal to 0, be careful!") x <- na_zero(x) return(sum(x)) } diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index 5ffc6f4..acba675 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -50,7 +50,7 @@ test_that("Function subs out NAs in numeric vectors with 0", { # Test that na_sum works test_that("NA Sum takes sum setting NA values to 0", { expect_equivalent(na_sum(c(1:10, NA)), sum(1:10, 0)) - expect_message(na_sum(c(1:10, NA)), "Taking a sum with missing values equal to 0, be careful! \u1F601") + expect_message(na_sum(c(1:10, NA)), "Taking a sum with missing values equal to 0, be careful!") }) test_that("na_sum fails with non-numerics", { -- 2.54.0