This report is automatically generated with the R
package knitr
(version 1.40
)
.
sigfig <- function(vec, n=3){ ### function to print values to N significant digits without dropping trailing zeros # input: vec vector of numeric # n integer is the required sigfig # output: outvec vector of numeric rounded to N sigfig # returns a character output - used in "hovertext" for plotly graphs formatC(signif(vec,digits=n), digits=n, format="fg", flag="#") } predictionModelPlot <- function(source, knownXlabel=NULL, .predictedYcol=predictedY, predictedYsigfigs=3, .groupByCol, allGroups=NULL, title='', xTitle=NULL, yTitle=NULL, color='', showLegend=F){ # source - a single row from a predictionModels() object # .groupByCol - column that will be used to distinguish by color and shape # allGroups - a vector of all unique values in the .groupByCol, which might be a subset # .predictedYcol - defaults to the "predictedY" col returned by predictionModels(); usually renamed by user to something more identifiable # source <- LMBSafeLevels_Subarea[1,] # example data from "Recalculate LMB Safe Level.R" # .predictedYcol <- quo(LMBSafeLevel) - to test function line-wise predictedYcol <- enquo(.predictedYcol) # .groupByCol <- quo(TMDL) - to test function line-wise groupBy <- enquo(.groupByCol) # extract data and model from source dataframe <- source$data[[1]] .knownXcol <- quo(!!sym(source$knownXcol)) dfKnownXcol <- enquo(.knownXcol) known_Xlabel <- if (is.null(knownXlabel)){ paste0(as_label(dfKnownXcol),'<sub>known</sub>=',source$knownX) } else { paste0(knownXlabel,'=',source$knownX) } .knownYcol <- quo(!!sym(source$knownYcol)) dfKnownYcol <- enquo(.knownYcol) dfKnownX <- source$knownX # Regression Model model <- source$Model[[1]] modelName <- source$ModelName model_predict <- tibble(!!dfKnownXcol := seq(floor( min(dataframe %>% pull(!!dfKnownXcol), dfKnownX)*95)/100, ceiling(max(dataframe %>% pull(!!dfKnownXcol), dfKnownX)*105)/100, length.out=500)) model_predictOrig <- model_predict %>% mutate(!!dfKnownYcol := case_when(modelName == 'pwr' | modelName == 'exp' ~ exp(predict(model, model_predict %>% select(!!dfKnownXcol))), T ~ predict(model, model_predict %>% select(!!dfKnownXcol)))) #ggplot shapes & colors Subareas <- if(!is.null(allGroups)) allGroups else unique(dataframe %>% pull(!!groupBy)) mySubareashapes <- c(15, 16, 17, 18, 8, 22, 21, 23, 24, 4) Subareashapes <- setNames(mySubareashapes[1:length(Subareas)], Subareas) # color safe palette - https://personal.sron.nl/~pault/#sec:qualitative if(color == ''){ mySubareacolors <- c('#0077BB','#33BBEE','#009988','#EE7733','#CC3311','#EE3377', '#919191') # Changed '#BBBBBB' light gray to '#919191' darker gray Subareacolors <- setNames(mySubareacolors[1:length(Subareas)], Subareas) } else { mySubareacolors <- rep(color, 6) Subareacolors <- setNames(mySubareacolors[1:length(Subareas)], Subareas) } used_colors_orig <- Subareacolors[unique(dataframe %>% pull(!!groupBy))] used_shapes_orig <- Subareashapes[unique(dataframe %>% pull(!!groupBy))] xMax <- ceiling(max(model_predictOrig[[1]])*10)/10 #ceiling(max(dataframe %>% select(!!dfKnownXcol), dfKnownX*1.1)*10)/10 yMax <- ceiling(max(model_predictOrig[[2]], max(dataframe %>% select(!!dfKnownYcol)))*10)/10 xscale <- xMax / as.numeric(gsub("\\.+|0+","", xMax)) # removes 0's and "." from value #Plot Data Points & Regression Line regressionGraph <- ggplot() + ggtitle(title) + xlab(if(is.null(xTitle)){as_label(dfKnownXcol)}else{xTitle}) + ylab(if(is.null(yTitle)){as_label(dfKnownYcol)}else{yTitle}) + # ylab('Average Aqueous MeHg<sub>unf</sub> (ng/L)') + #Data Points geom_point(data=dataframe, aes(x=!!dfKnownXcol, y=!!dfKnownYcol, color=!!groupBy, shape=!!groupBy), alpha=1, size=3, show.legend=T) + #Regression Line geom_point(data=model_predictOrig, aes(x=!!dfKnownXcol, y=!!dfKnownYcol), color='grey26', size=.3, show.legend=F) + #Regression Model SER (Standard Error of Regression) annotate("text", x=xMax * 1/5, y=mean(c(yMax, source %>% pull(!!predictedYcol))), # source %>% pull(!!predictedYcol)*1.9, label=paste0('Model<sub>', source$ModelName, '</sub>SER=', sigfig(source$SER,3),''), color='grey26') + #Scale & Theme scale_x_continuous(expand = c(0, 0), limits = c(0, xMax)) + scale_y_continuous(expand = c(0, 0), limits = c(0, yMax)) + scale_color_manual(values = used_colors_orig) + scale_shape_manual(values = used_shapes_orig) + theme_light() + theme(text = element_text(size=14), legend.position=if(showLegend == F){'none'}else{''}, # Hide legend in plotly legend.title = element_blank()) regressionPlotly <- ggplotly(regressionGraph, tooltip='text') #REMOVE Paranethesis & commas that ggplotly sometimes adds to legend labes #https://stackoverflow.com/questions/49133395/strange-formatting-of-legend-in-ggplotly-in-r for (i in 1:length(regressionPlotly$x$data)){ if (!is.null(regressionPlotly$x$data[[i]]$name)){ regressionPlotly$x$data[[i]]$name = gsub("\\(","",str_split(regressionPlotly$x$data[[i]]$name,",")[[1]][1]) } } #Add Prediction Line predictionGraph <- regressionGraph + #Vertical Line geom_segment(aes(x=source$knownX, xend=source$knownX, y=0, yend=source %>% pull(!!predictedYcol)), color='grey26') + #Vertical Line Text - Known X annotate("text", x=source$knownX + 0, hjust=0, y=source %>% pull(!!predictedYcol)/4, label=known_Xlabel, color='grey26') + #Horizontal Line geom_segment(aes(x=0, xend=source$knownX, y=source %>% pull(!!predictedYcol), yend=source %>% pull(!!predictedYcol)), color='grey26') + #Horizontal Line Text - Predicted Y annotate("text", x=source$knownX/2, y=source %>% pull(!!predictedYcol), label=paste0('Predicted<sub>',as_label(dfKnownYcol),'</sub><br>', sigfig(source %>% pull(!!predictedYcol), predictedYsigfigs)), color='grey26') predictionPlotly <- ggplotly(predictionGraph, tooltip='text') #REMOVE Paranethesis & commas that ggplotly sometimes adds to legend labes #https://stackoverflow.com/questions/49133395/strange-formatting-of-legend-in-ggplotly-in-r for (i in 1:length(predictionPlotly$x$data)){ if (!is.null(predictionPlotly$x$data[[i]]$name)){ predictionPlotly$x$data[[i]]$name = gsub("\\(","",str_split(predictionPlotly$x$data[[i]]$name,",")[[1]][1]) } } if(is.null(knownXlabel)){ return(regressionPlotly) } else return(predictionPlotly) # htmlwidgets::saveWidget(plotly::as_widget(regressionPlotly), "test.html") #if get an error try a simple file name }
The R session information (including the OS info, R version and all packages used):
sessionInfo()
## R version 4.2.2 (2022-10-31 ucrt) ## Platform: x86_64-w64-mingw32/x64 (64-bit) ## Running under: Windows 10 x64 (build 22621) ## ## Matrix products: default ## ## locale: ## [1] LC_COLLATE=English_United States.utf8 LC_CTYPE=English_United States.utf8 ## [3] LC_MONETARY=English_United States.utf8 LC_NUMERIC=C ## [5] LC_TIME=English_United States.utf8 ## ## attached base packages: ## [1] stats graphics grDevices utils datasets methods base ## ## other attached packages: ## [1] mgcv_1.8-41 nlme_3.1-160 lubridate_1.8.0 plotly_4.10.0 ## [5] readxl_1.4.1 actuar_3.3-0 NADA_1.6-1.1 forcats_0.5.2 ## [9] stringr_1.4.1 dplyr_1.0.9 purrr_0.3.4 readr_2.1.2 ## [13] tidyr_1.2.0 tibble_3.1.8 ggplot2_3.3.6 tidyverse_1.3.2 ## [17] fitdistrplus_1.1-8 survival_3.4-0 MASS_7.3-58.1 ## ## loaded via a namespace (and not attached): ## [1] lattice_0.20-45 assertthat_0.2.1 digest_0.6.29 utf8_1.2.2 ## [5] R6_2.5.1 cellranger_1.1.0 backports_1.4.1 reprex_2.0.2 ## [9] evaluate_0.16 highr_0.9 httr_1.4.4 pillar_1.8.1 ## [13] rlang_1.0.5 lazyeval_0.2.2 googlesheets4_1.0.1 rstudioapi_0.14 ## [17] data.table_1.14.2 Matrix_1.5-1 splines_4.2.2 googledrive_2.0.0 ## [21] htmlwidgets_1.5.4 munsell_0.5.0 broom_1.0.1 compiler_4.2.2 ## [25] modelr_0.1.9 xfun_0.32 pkgconfig_2.0.3 htmltools_0.5.3 ## [29] tidyselect_1.1.2 fansi_1.0.3 viridisLite_0.4.1 crayon_1.5.1 ## [33] tzdb_0.3.0 dbplyr_2.2.1 withr_2.5.0 grid_4.2.2 ## [37] jsonlite_1.8.0 gtable_0.3.1 lifecycle_1.0.1 DBI_1.1.3 ## [41] magrittr_2.0.3 scales_1.2.1 cli_3.3.0 stringi_1.7.8 ## [45] fs_1.5.2 xml2_1.3.3 ellipsis_0.3.2 generics_0.1.3 ## [49] vctrs_0.4.1 expint_0.1-7 tools_4.2.2 glue_1.6.2 ## [53] hms_1.1.2 fastmap_1.1.0 colorspace_2.0-3 gargle_1.2.0 ## [57] rvest_1.0.3 knitr_1.40 haven_2.5.1
Sys.time()
## [1] "2023-12-26 09:32:30 PST"