From 4f0a17d821c23218562e22daa61d041f52143224 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 26 Jun 2025 10:17:24 +0200 Subject: [PATCH] publishing with docker --- .github/workflows/docker-build.yml | 49 + CITATION.cff | 13 - DESCRIPTION | 3 +- R/sysdata.rda | Bin 2785 -> 2769 bytes SESSION.md | 10 +- app_docker/.dockerignore | 6 + app_docker/Dockerfile | 12 + app_docker/app.R | 11275 ++++++++++++++++++++++++++ app_docker/www/FreesearchR-logo.png | Bin 0 -> 22712 bytes app_docker/www/favicon.ico | Bin 0 -> 15086 bytes app_docker/www/favicon.png | Bin 0 -> 28511 bytes app_docker/www/favicon.svg | 3 + app_docker/www/intro.html | 438 + app_docker/www/intro.md | 31 + app_docker/www/references.bib | 11 + app_docker/www/report.rmd | 83 + app_docker/www/style.css | 125 + app_docker/www/umami-app.html | 1 + app_docker/www/web_data.rds | Bin 0 -> 1737943 bytes renv.lock | 48 - 20 files changed, 12040 insertions(+), 68 deletions(-) create mode 100644 .github/workflows/docker-build.yml create mode 100644 app_docker/.dockerignore create mode 100644 app_docker/Dockerfile create mode 100644 app_docker/app.R create mode 100644 app_docker/www/FreesearchR-logo.png create mode 100755 app_docker/www/favicon.ico create mode 100644 app_docker/www/favicon.png create mode 100755 app_docker/www/favicon.svg create mode 100644 app_docker/www/intro.html create mode 100644 app_docker/www/intro.md create mode 100644 app_docker/www/references.bib create mode 100644 app_docker/www/report.rmd create mode 100644 app_docker/www/style.css create mode 100644 app_docker/www/umami-app.html create mode 100644 app_docker/www/web_data.rds diff --git a/.github/workflows/docker-build.yml b/.github/workflows/docker-build.yml new file mode 100644 index 0000000..3cd45b8 --- /dev/null +++ b/.github/workflows/docker-build.yml @@ -0,0 +1,49 @@ +name: Build and Push Docker Image +permissions: + contents: read + packages: write + +on: + # push: + # branches: + # - main + # - master + release: + types: [published] + workflow_dispatch: + +jobs: + build: + runs-on: ubuntu-latest + + steps: + - name: Checkout code + uses: actions/checkout@v3 + + - name: Setup Docker Buildx + uses: docker/setup-buildx-action@v2 + + - name: Login to GitHub Container Registry + uses: docker/login-action@v2 + with: + registry: ghcr.io + username: ${{ github.actor }} + password: ${{ secrets.GITHUB_TOKEN }} + + - name: Define lowercase variables + id: vars + run: | + REPO_OWNER_LOWER=$(echo "$GITHUB_REPOSITORY_OWNER" | tr '[:upper:]' '[:lower:]') + REPO_NAME_LOWER=$(echo "$GITHUB_REPOSITORY" | cut -d'/' -f2 | tr '[:upper:]' '[:lower:]') + echo "REPO_OWNER_LOWER=$REPO_OWNER_LOWER" >> $GITHUB_ENV + echo "REPO_NAME_LOWER=$REPO_NAME_LOWER" >> $GITHUB_ENV + + - name: Build and push Docker image + uses: docker/build-push-action@v4 + with: + context: . + file: app_docker/Dockerfile + push: true + tags: | + ghcr.io/${{ env.REPO_OWNER_LOWER }}/${{ env.REPO_NAME_LOWER }}:latest + ghcr.io/${{ env.REPO_OWNER_LOWER }}/${{ env.REPO_NAME_LOWER }}:${{ github.sha }} diff --git a/CITATION.cff b/CITATION.cff index ed962eb..fbe8420 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -1002,19 +1002,6 @@ references: email: russell-lenth@uiowa.edu year: '2025' doi: 10.32614/CRAN.package.emmeans -- type: software - title: visdat - abstract: 'visdat: Preliminary Visualisation of Data' - notes: Imports - url: https://docs.ropensci.org/visdat/ - repository: https://CRAN.R-project.org/package=visdat - authors: - - family-names: Tierney - given-names: Nicholas - email: nicholas.tierney@gmail.com - orcid: https://orcid.org/0000-0003-1460-8722 - year: '2025' - doi: 10.32614/CRAN.package.visdat - type: software title: styler abstract: 'styler: Non-Invasive Pretty Printing of R Code' diff --git a/DESCRIPTION b/DESCRIPTION index 46be950..439b731 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -79,7 +79,8 @@ Suggests: testthat (>= 3.0.0), shinytest, covr, - cffr + cffr, + shiny2docker URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/, https://app.FreesearchR.org/ BugReports: https://github.com/agdamsbo/FreesearchR/issues VignetteBuilder: knitr diff --git a/R/sysdata.rda b/R/sysdata.rda index 95b884224dab1448dc4f948cecb9794c7511a93e..e24deec4ecb011461697641b10e8b02eeacf8de7 100644 GIT binary patch literal 2769 zcmV;?3NH0RT4*^jL0KkKSxUjQ0Z|HA+OXazw3|KNXb-@w2B|L{NnAOHvf;0#|E zI|yCr2dU;_y@2#6P)rA)DIgR$YGMh9Xwy(+GAV|E6BPEL9+29A22WAxskA*PH9Y`| zCPX$!0j8dy0000000051ei0O@iGTnA0000000009G?5V~^-s~NZ9_l|n9(r+WMt8h zF)#ue1C0#>MwuFD(;zW0KmarbfYTr_CP0Zv1i(|$HjPHqY3el4(-1T?&gNGyEpu>l^Bn;<;+M%Q zP)b7pSlF9ZGxh6PKr^Cjq@imVt7?LZE zxI*uZLifJe-*K0*V_0Z{){KMMkNZ+~@n z)pGRIM3LfUK!EiCt07i1Qtt^8Qq4waB*FqlO&WFfPW^&^c3%a|s-3xrR%n3ROXS&DQ7@`AE`D@rH12BJA&cMKMXEDx@;Y%+Dg? z_)I;+gvF^wCPc$g#FUD?-tBpIMT%x|S4XP6EUYcao03G+rRiQNVdUPC5lIsi*&bq5 zL}He=HneEi;Ek%kU3(4IU)iDU714WWl(i?en!ScQzQTrTU!n; z310U1Mj#`B!ET9e5s-wCgoJ{{P*NyG1W2j~!4;83AfXjN6ckt~5kwV5kx`IW$ori$ zeqeDI&?Yh{o+^$xwcdEfs}$2XR<9gg>Q*VVl`oB?G1Faa&Acwdj4V-2vTemq5UIx& z-d*houGWH7S}>v&1Z|=~*wWFRAqdbqUEFzQnbTbIX>JT?XEc~^d7H4XRK+Z&NNYqz zCMB!73CpK;Eaqm!ZqShLNX%m}oSB_aRScj_8_jB%s17qx#LEm3RL)$;NRq;479!c%2OEym{*YA#WVTGcCb&l@Z3$=>`$OV;EL(FcrLp4Ix#c2`3&Hgv86K6^ax!Ju{pR4h2VYNGt$_3vJb{ zs$FXiGdE(S1(bAXB6U_}(ij+YBXrU$Ilyy6oH-UnQ3NG9YBdm`o&$;e$qUC0Oz!8= zi%a~dD)N~HYD2=vWu!0HQNeAt*=@K1EHc{3MV`wBPiZ})@469PrPLD4Wzl%6Ll(?d(=gcph84>Z ztBqy~m0Y$cF|yHaB*(0sktNI9ssj$x+{p`6wUWdXh``EbMgGZ)BMX3#F;GT?0E9>o zZ_sX@jfpB&w#ekD7OCGl`q%r` z-{Hdy@6Cz5g=a)BaoUrx_Q@c7sQ?dmKxmv&P?nISC8`Ag3Q%aGmW`U(YoJmoAj7XN z#i}HLJ_h-1z}HgRtp@sd1w~cWD;W`j2GCemO00H|bvx~lL>Jz*?5` zt7%rt7c7Hwt?)~ueA(OnuDVW)DO#rmhKZ&btva+2ryc*@*+?pz& z@#4jXnDrGw%@cb9cm1P<%BdQe#zr^iA7Mn3!lP$J2%-Mm*#@HPT@H16o=k*D5WHo(L1h zzdV&ffN<)mJaKbXb8}XKaNpfB8mRhMHMti7orTqIt(9gBng~V9L@<#`9giJy!_`V- zF-XWPh&U)R4c1;pT~+JA5W2Uy@;rfZvEz)#aQ2=WiKTMkP$9Ulx7~W~hOf?~WED(s z4GC*?%uMI4!gW>G^_})OpyA31SiSNsajPC0U%k8w)%I!8NYI3*jeY~!=e|mr2#Nx) zsbn|gnN&f|n5a0K=k_H_*l#OwTQSs1GTsRXS*nDUn-mkyUq*oJh~Hz|=Hla*Kv;+9 ze9&ii5dLNyU4BPUU0Oe)5xJEQc@D3n+AZURq#|MCl+-L(A#kh`zK5{2HO)j1KC_*} zTgK?km-#KV8(j{4eeE0pD79-s~cR z&MI-c*vvL>N>TAUeO*s+m##)DBiJ3Iw#$mks$?EQ8o?r<`i~aOxm<`N=8iECw5&H8 zWW{#Xv!4%h-Lh)U>|xpMGzHawlerLKy)s#>ieU&i!sl{i8c?{K2C)T^bTV%@h!b@Z z!ZNdXp1}!F2HupXBU1)lc4Xjb(V>*LY~sU&ZMjhScMXC9_giMLU997@gVmu_o}`uC z4C?o8)FcKNp91hILEC*LQ}JLTz|UqG0rnWkXBvpZov#mD`E3t|WfE7aNoRr9UC^}V zE$jBmeQupH77JNrXU>^E7 z>XMzbqC`)VYS@)F_IlQ>bXr&6%023!y+jPzw?&SDNc8KnUX8o_E4aB94PNWYS`4>s zvp#>e9UAyY8#b2mmG?Osp`)(4{lYqlbV)A~h~p~Y`-ni3dhV%?sb;}sN$Opt*`W9V X@}b?W8UWGb5B@IXig2MJn5xviS$-B@ literal 2785 zcmV<73Lf=BT4*^jL0KkKSsTbri2xdsf5QL&Xazw3|KNXb-@w2B|L{Nn2mlBH;0#|E zJ1Q4?LF)00t&V`80(cIJ732*AhNd70Xar;$A)`@qZ*n$L8hBgqeg>6 zLqKV#lmo>yXk@VzHIaakbqdSUQge_hmSI2~osNk@D!ke$C;>)_2rlpbHn8nl0@z#S z`15j@1mcA+krR@Vg0Qo>8@6!m&XEGtASycW0mpyktA9_%KaPGrB>&Iu+$sFM`{Ecq zbCs}>tbD0rd@DN**UHa)1+awf&rul82YAT_6|~4Ozt3US>ERqQqL4cghN~5ckVEB6 zF+^Rp4+e6XEIMU5$kVH2M7FZjpg?+nRgkM0sdt2lDTbpo5@7)&P7QV7TUagowtL6- zYlpfsDC)whud>3l96}M`Y+4LWfq}3#BOG{!IF~ui-uOlDXy37+ zWWzc2Ci@KI((t`E!j4=wF9!&$osF8$Ql%%B@?ntV(4{!Ln_EDx$ka_;vx5RDoz1+l zNRtYrGTY40TE*ou_8ca0N;5Jh8jfV7RomNKyCTIiIIBmi4v?<2L{TJ7x?L;9EIgZ} zRa7KQQ)u%Nsv|VD%fXH|ZXlP1rS3Gx9&Bt#xANUaUA84#4iQ=g)^Xj<0~DjB0D}-J zl||~WVy6DZI`MD~=u{Ni09ZsJ02GKQqCkNngoQ{DP~?O}al(QH8!;m8lmvEi<~K2* zIN$(GnKEL_7B6t~;XxW}E4d`17$AlSV1z|ttVRH$f{|1af~t{4kWh$#EEQm+MPQ<% zBBLO$f5+=L?R_BTFT^I96i-D*Gh9~d*d8*hQ*6a*@x|VyVw*`)`wbzEn(Jn5;dUHh zV#PMew-q=-ryN^uW>9KPggRD$ni9i^gh(06v=AJj1q|bhk1W$V*F2hAgBlslCL7*n z>?{&Q6tJL?3do629V)2`9ZYN9;^!&K?8HI^V|JLgMiu#7rbq;|LXjCZ<)1G=WYf zu$Uu!bGL_0J;hHuk-k2^Q)D036T$IG>Y?DsWuz~XjtgzJ%Wc90u*+*D7JeoSp6Yw2 z$aEsRWz-VPWu+4shcXzpVz!xv$OJI1SdCn3FjT7Lu|bWNi*Y7Br0!#uNMZ(&)|60E8Q;qFxo(4YosfibfokTQ^xVJ%Q7 z0AF7uz>*!u*4}^?K}epv@DMSAfcQ7k+zoVFRiNLikSeM!saVL25H^CsvQ=ZWeM)&- zAc!yPwd9q8yt9ObNuF(dKE>kN*0xkuaht%x#fG7Cd*i@6j(_sB$mSg%MO!EmLe(glN@S0Ohj#3#{8RBO%*sr zkk3!K>UVR&ZSCcB*E(I5Z7SJf<&bW6x#2RK=Fd0zy6SYwiCU)xCZy9UW{qm2TH9?{ zvU#j6jFQ4c8C^Y`<(-aA%A;F$|4$7_ z2U z!itr<&)f2R*L>Wru5EI_=10@?xETL(UttqWe%|jhSo)$q_I>6eg78|WaFng3#!zQ4 z&o!pmzvCSwANV+DNDh`N{61z=kWSRNpjtkuzJNhaljv9m646!_lOSTY<{|m8t6k*N z^$+RGxpE~7Y4l%tztK)f$6k!sXo>NY zG0z+A2k023LOpZ6Y-OV43F@+*`qgAqKxow-rmJiF|gtsxE)#oZhpbLk5b_@818_HYpFFyia^JT3Y|rZTOM9^xFngJ`FP)yzo52OC1E zSRq)T61^~CF|5HLeP?Z9<7{kQeu*DFi`^Tns9^`88zSzHF00tp^pTp;@D8)DYjEvuQ|8FeJQc=n zlVon5J;hO{B(ji=MM=2RHY?2iU7NkIcB@ss3}MskGzHago4Al+!82)-n1U{Y&vhC@ zLNYI4>_KWbt!nC^v#YUMZTP0a6BYxDp<+nnF!%3LWpKCJG&nD~bgVVaxcI53sFVy7 zAc~rTWiiZz6=6L*5_R;mm$zmDU|o^!F4Dd(*YgwMlK~aRdale5sK#S_o<xTUd`JU11>m zO7F16HslAC#|XifQN3juI%tK|(^6`x#ROTXhVq`{oQ_&?M~HgQFkA87qOxk`M=j%e zU~O_Brfs2~C)LNIjk_*4Z(BTk**fTFn~T@8J8M-#IM9tfV&`DG-l1tAkt>DmAV?W> z!bC1it6S@9aHex)(vnV9B{_yrxI{I8c)P-cTLVnU0N`RZtrtv_g67s*7~tC)%=lg| zp$(~exYn#sO0Dg#GrpUcv4qs^Wg;Sk+WkoO*uwEzvAu~$cSO6Dc(Ftb*{?;8p?tYx zO#M3c_t9B#E1J6Y3FtG~uATh;xZ$=s=+s*Zs^;WshWAc&<|TP9 baseline_table() +#' mtcars |> baseline_table(fun.args = list(by = "gear")) +baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { + + out <- do.call(fun, c(list(data = data), fun.args)) + return(out) +} + + + +#' Create a baseline table +#' +#' @param data data +#' @param ... passed as fun.arg to baseline_table() +#' @param strat.var grouping/strat variable +#' @param add.p add comparison/p-value +#' @param add.overall add overall column +#' +#' @returns gtsummary table list object +#' @export +#' +#' @examples +#' mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") +#' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon")) { + theme <- match.arg(theme) + + if (by.var == "none" | !by.var %in% names(data)) { + by.var <- NULL + } + + ## These steps are to handle logicals/booleans, that messes up the order of columns + ## Has been reported and should be fixed soon (02042025) + + if (!is.null(by.var)) { + if (identical("logical", class(data[[by.var]]))) { + data[by.var] <- as.character(data[[by.var]]) + } + } + + suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme)) + + args <- list(...) + + parameters <- list( + data = data, + fun.args = list(by = by.var, ...) + ) + + out <- do.call( + baseline_table, + parameters + ) + + + if (!is.null(by.var)) { + if (isTRUE(add.overall)) { + out <- out |> gtsummary::add_overall() + } + if (isTRUE(add.p)) { + out <- out |> + gtsummary::add_p() |> + gtsummary::bold_p() + } + } + + out +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//contrast_text.R +######## + +#' @title Contrast Text Color +#' @description Calculates the best contrast text color for a given +#' background color. +#' @param background A hex/named color value that represents the background. +#' @param light_text A hex/named color value that represents the light text +#' color. +#' @param dark_text A hex/named color value that represents the dark text color. +#' @param threshold A numeric value between 0 and 1 that is used to determine +#' the luminance threshold of the background color for text color. +#' @param method A character string that specifies the method for calculating +#' the luminance. Three different methods are available: +#' c("relative","perceived","perceived_2") +#' @param ... parameter overflow. Ignored. +#' @details +#' This function aids in deciding the font color to print on a given background. +#' The function is based on the example provided by teppo: +#' https://stackoverflow.com/a/66669838/21019325. +#' The different methods provided are based on the methods outlined in the +#' StackOverflow thread: +#' https://stackoverflow.com/questions/596216/formula-to-determine-perceived-brightness-of-rgb-color +#' @return A character string that contains the best contrast text color. +#' @examples +#' contrast_text(c("#F2F2F2", "blue")) +#' +#' contrast_text(c("#F2F2F2", "blue"), method="relative") +#' @export +#' +#' +contrast_text <- function(background, + light_text = 'white', + dark_text = 'black', + threshold = 0.5, + method = "perceived_2", + ...) { + if (method == "relative") { + luminance <- + c(c(.2126, .7152, .0722) %*% grDevices::col2rgb(background) / 255) + } else if (method == "perceived") { + luminance <- + c(c(.299, .587, .114) %*% grDevices::col2rgb(background) / 255) + } else if (method == "perceived_2") { + luminance <- c(sqrt(colSums(( + c(.299, .587, .114) * grDevices::col2rgb(background) + ) ^ 2)) / 255) + } + + ifelse(luminance < threshold, + light_text, + dark_text) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//correlations-module.R +######## + +#' Data correlations evaluation module +#' +#' @param id Module id. (Use 'ns("id")') +#' +#' @name data-correlations +#' @returns Shiny ui module +#' @export +data_correlations_ui <- function(id, ...) { + ns <- shiny::NS(id) + + shiny::tagList( + shiny::textOutput(outputId = ns("suggest")), + shiny::plotOutput(outputId = ns("correlation_plot"), ...) + ) +} + + +#' +#' @param data data +#' @param color.main main color +#' @param color.sec secondary color +#' @param ... arguments passed to toastui::datagrid +#' +#' @name data-correlations +#' @returns shiny server module +#' @export +data_correlations_server <- function(id, + data, + include.class = NULL, + cutoff = .7, + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + # ns <- session$ns + + rv <- shiny::reactiveValues( + data = NULL + ) + + rv$data <- shiny::reactive({ + shiny::req(data) + if (!is.null(include.class)) { + filter <- sapply(data(), class) %in% include.class + out <- data()[filter] + } else { + out <- data() + } + # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) + sapply(out,as.numeric) + # as.numeric() + }) + + # rv <- list() + # rv$data <- mtcars + + output$suggest <- shiny::renderPrint({ + shiny::req(rv$data) + shiny::req(cutoff) + pairs <- correlation_pairs(rv$data(), threshold = cutoff()) + + more <- ifelse(nrow(pairs) > 1, "from each pair ", "") + + if (nrow(pairs) == 0) { + out <- glue::glue("No variables have a correlation measure above the threshold.") + } else { + out <- pairs |> + apply(1, \(.x){ + glue::glue("'{.x[1]}'x'{.x[2]}'({round(as.numeric(.x[3]),2)})") + }) |> + (\(.x){ + glue::glue("The following variable pairs are highly correlated: {sentence_paste(.x)}.\nConsider excluding one {more}from the dataset to ensure variables are independent.") + })() + } + out + }) + + output$correlation_plot <- shiny::renderPlot({ + ggcorrplot::ggcorrplot(cor(rv$data())) + + # ggplot2::theme_void() + + ggplot2::theme( + # legend.position = "none", + legend.title = ggplot2::element_text(size = 20), + legend.text = ggplot2::element_text(size = 14), + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + axis.text.x = ggplot2::element_text(size = 20), + axis.text.y = ggplot2::element_text(size = 20), + # text = element_text(size = 5), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + # plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank() + ) + # psych::pairs.panels(rv$data()) + }) + } + ) +} + +correlation_pairs <- function(data, threshold = .8) { + data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)] + data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame() + # data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric)) + cor <- Hmisc::rcorr(as.matrix(data)) + r <- cor$r %>% as.table() + d <- r |> + as.data.frame() |> + dplyr::filter(abs(Freq) > threshold, Freq != 1) + + d[1:2] |> + apply(1, \(.x){ + sort(unname(.x)) + }, + simplify = logical(1) + ) |> + duplicated() |> + (\(.x){ + d[!.x, ] + })() |> + setNames(c("var1", "var2", "cor")) +} + +sentence_paste <- function(data, and.str = "and") { + and.str <- gsub(" ", "", and.str) + if (length(data) < 2) { + data + } else if (length(data) == 2) { + paste(data, collapse = glue::glue(" {and.str} ")) + } else if (length(data) > 2) { + paste(paste(data[-length(data)], collapse = ", "), data[length(data)], sep = glue::glue(" {and.str} ")) + } +} + + + + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//create-column-mod.R +######## + +#' @title Create new column +#' +#' @description +#' This module allow to enter an expression to create a new column in a `data.frame`. +#' +#' +#' @param id Module's ID. +#' +#' @return A [shiny::reactive()] function returning the data. +#' +#' @note User can only use a subset of function: `r paste(list_allowed_operations(), collapse=", ")`. +#' You can add more operations using the `allowed_operations` argument, for example if you want to allow to use package lubridate, you can do: +#' ```r +#' c(list_allowed_operations(), getNamespaceExports("lubridate")) +#' ``` +#' +#' @export +#' +#' @importFrom htmltools tagList tags css +#' +#' @name create-column +#' +#' @example examples/create_column_module_demo.R +create_column_ui <- function(id) { + ns <- NS(id) + htmltools::tagList( + # datamods:::html_dependency_datamods(), + # html_dependency_FreesearchR(), + shiny::tags$head( + shiny::tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css") + ), + # tags$head( + # # Note the wrapping of the string in HTML() + # tags$style(HTML(" + # /* modified from esquisse for data types */ + # .btn-column-categorical { + # background-color: #EF562D; + # color: #FFFFFF; + # } + # .btn-column-continuous { + # background-color: #0C4C8A; + # color: #FFFFFF; + # } + # .btn-column-dichotomous { + # background-color: #97D5E0; + # color: #FFFFFF; + # } + # .btn-column-datetime { + # background-color: #97D5E0; + # color: #FFFFFF; + # } + # .btn-column-id { + # background-color: #848484; + # color: #FFFFFF; + # } + # .btn-column-text { + # background-color: #2E2E2E; + # color: #FFFFFF; + # }")) + # ), + fluidRow( + column( + width = 6, + textInput( + inputId = ns("new_column"), + label = i18n("New column name:"), + value = "new_column1", + width = "100%" + ) + ), + column( + width = 6, + shinyWidgets::virtualSelectInput( + inputId = ns("group_by"), + label = i18n("Group calculation by:"), + choices = NULL, + multiple = TRUE, + disableSelectAll = TRUE, + hasOptionDescription = TRUE, + width = "100%" + ) + ) + ), + shiny::textAreaInput( + inputId = ns("expression"), + label = i18n("Enter an expression to define new column:"), + value = "", + width = "100%", + rows = 6 + ), + tags$i( + class = "d-block", + phosphoricons::ph("info"), + datamods::i18n("Click on a column name to add it to the expression:") + ), + uiOutput(outputId = ns("columns")), + uiOutput(outputId = ns("feedback")), + tags$div( + style = htmltools::css( + display = "grid", + gridTemplateColumns = "3fr 1fr", + columnGap = "10px", + margin = "10px 0" + ), + actionButton( + inputId = ns("compute"), + label = tagList( + phosphoricons::ph("gear"), i18n("Create column") + ), + class = "btn-outline-primary", + width = "100%" + ), + actionButton( + inputId = ns("remove"), + label = tagList( + phosphoricons::ph("trash") + ), + class = "btn-outline-danger", + width = "100%" + ) + ) + ) +} + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' @param allowed_operations A `list` of allowed operations, see below for details. +#' +#' @export +#' +#' @rdname create-column +#' +create_column_server <- function(id, + data_r = reactive(NULL), + allowed_operations = list_allowed_operations()) { + moduleServer( + id, + function(input, output, session) { + ns <- session$ns + + info_alert <- shinyWidgets::alert( + status = "info", + phosphoricons::ph("question"), + datamods::i18n("Choose a name for the column to be created or modified,"), + datamods::i18n("then enter an expression before clicking on the button above to validate or on "), + phosphoricons::ph("trash"), datamods::i18n("to delete it.") + ) + + rv <- reactiveValues( + data = NULL, + feedback = info_alert + ) + + observeEvent(input$hidden, rv$feedback <- info_alert) + + bindEvent(observe({ + data <- data_r() + shinyWidgets::updateVirtualSelect( + inputId = "group_by", + choices = make_choices_with_infos(data) + ) + }), data_r(), input$hidden) + + observeEvent(data_r(), rv$data <- data_r()) + + output$feedback <- renderUI(rv$feedback) + + output$columns <- renderUI({ + data <- req(rv$data) + mapply( + label = names(data), + data = data, + FUN = btn_column, + MoreArgs = list(inputId = ns("add_column")), + SIMPLIFY = FALSE + ) + }) + + observeEvent(input$add_column, { + updateTextAreaInput( + session = session, + inputId = "expression", + value = paste0(input$expression, input$add_column) + ) + }) + + observeEvent(input$new_column, { + if (input$new_column == "") { + rv$feedback <- shinyWidgets::alert( + status = "warning", + phosphoricons::ph("warning"), datamods::i18n("New column name cannot be empty") + ) + } + }) + + observeEvent(input$remove, { + rv$data[[input$new_column]] <- NULL + }) + observeEvent(input$compute, { + rv$feedback <- try_compute_column( + expression = input$expression, + name = input$new_column, + rv = rv, + allowed_operations = allowed_operations, + by = input$group_by + ) + }) + + return(reactive(rv$data)) + } + ) +} + +#' @export +#' +#' @rdname create-column +# @importFrom methods getGroupMembers +list_allowed_operations <- function() { + c( + "(", "c", + # getGroupMembers("Arith"), + c("+", "-", "*", "^", "%%", "%/%", "/"), + # getGroupMembers("Compare"), + c("==", ">", "<", "!=", "<=", ">="), + # getGroupMembers("Logic"), + c("&", "|"), + # getGroupMembers("Math"), + c( + "abs", "sign", "sqrt", "ceiling", "floor", "trunc", "cummax", + "cummin", "cumprod", "cumsum", "exp", "expm1", "log", "log10", + "log2", "log1p", "cos", "cosh", "sin", "sinh", "tan", "tanh", + "acos", "acosh", "asin", "asinh", "atan", "atanh", "cospi", "sinpi", + "tanpi", "gamma", "lgamma", "digamma", "trigamma" + ), + # getGroupMembers("Math2"), + c("round", "signif"), + # getGroupMembers("Summary"), + c("max", "min", "range", "prod", "sum", "any", "all"), + "pmin", "pmax", "mean", + "paste", "paste0", "substr", "nchar", "trimws", + "gsub", "sub", "grepl", "ifelse", "length", + "as.numeric", "as.character", "as.integer", "as.Date", "as.POSIXct", + "as.factor", "factor" + ) +} + + +#' @inheritParams shiny::modalDialog +#' @export +#' +#' @importFrom shiny showModal modalDialog textInput +#' @importFrom htmltools tagList +#' +#' @rdname create-column +modal_create_column <- function(id, + title = i18n("Create a new column"), + easyClose = TRUE, + size = "l", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + create_column_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + ), + easyClose = easyClose, + size = size, + footer = footer + )) +} + +#' @inheritParams shinyWidgets::WinBox +#' @export +#' +#' @importFrom shinyWidgets WinBox wbOptions wbControls +#' @importFrom htmltools tagList +#' @rdname create-column +winbox_create_column <- function(id, + title = i18n("Create a new column"), + options = shinyWidgets::wbOptions(), + controls = shinyWidgets::wbControls()) { + ns <- NS(id) + WinBox( + title = title, + ui = tagList( + create_column_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + ) + ), + options = modifyList( + shinyWidgets::wbOptions(height = "550px", modal = TRUE), + options + ), + controls = controls, + auto_height = FALSE + ) +} + + +try_compute_column <- function(expression, + name, + rv, + allowed_operations, + by = NULL) { + parsed <- try(parse(text = expression, keep.source = FALSE), silent = TRUE) + if (inherits(parsed, "try-error")) { + return(datamods:::alert_error(attr(parsed, "condition")$message)) + } + funs <- unlist(c(extract_calls(parsed), lapply(parsed, extract_calls)), recursive = TRUE) + if (!are_allowed_operations(funs, allowed_operations)) { + return(datamods:::alert_error(datamods::i18n("Some operations are not allowed"))) + } + if (!isTruthy(by)) { + result <- try( + rlang::eval_tidy(rlang::parse_expr(expression), data = rv$data), + silent = TRUE + ) + } else { + result <- try( + { + dt <- as.data.table(rv$data) + new_col <- NULL + dt[, new_col := rlang::eval_tidy(rlang::parse_expr(expression), data = .SD), by = by] + dt$new_col + }, + silent = TRUE + ) + } + if (inherits(result, "try-error")) { + return(alert_error(attr(result, "condition")$message)) + } + adding_col <- try(rv$data[[name]] <- result, silent = TRUE) + if (inherits(adding_col, "try-error")) { + return(alert_error(attr(adding_col, "condition")$message)) + } + code <- if (!isTruthy(by)) { + rlang::call2("mutate", !!!rlang::set_names(list(rlang::parse_expr(expression)), name)) + } else { + rlang::call2( + "mutate", + !!!rlang::set_names(list(rlang::parse_expr(expression)), name), + !!!list(.by = rlang::expr(c(!!!rlang::syms(by)))) + ) + } + attr(rv$data, "code") <- Reduce( + f = function(x, y) rlang::expr(!!x %>% !!y), + x = c(attr(rv$data, "code"), code) + ) + shinyWidgets::alert( + status = "success", + phosphoricons::ph("check"), datamods::i18n("Column added!") + ) +} + +are_allowed_operations <- function(x, allowed_operations) { + all( + x %in% allowed_operations + ) +} + + +extract_calls <- function(exp) { + if (is.call(exp)) { + return(list( + as.character(exp[[1L]]), + lapply(exp[-1L], extract_calls) + )) + } +} + +alert_error <- function(text) { + alert( + status = "danger", + phosphoricons::ph("bug"), text + ) +} + + +btn_column <- function(label, data, inputId) { + icon <- get_var_icon(data, "class") + type <- data_type(data) + tags$button( + type = "button", + class = paste0("btn btn-column-", type), + style = htmltools::css( + "--bs-btn-padding-y" = ".25rem", + "--bs-btn-padding-x" = ".5rem", + "--bs-btn-font-size" = ".75rem", + "margin-bottom" = "5px" + ), + if (!is.null(icon)) icon, + label, + onclick = sprintf( + "Shiny.setInputValue('%s', '%s', {priority: 'event'})", + inputId, label + ) + ) +} + +make_choices_with_infos <- function(data) { + lapply( + X = seq_along(data), + FUN = function(i) { + nm <- names(data)[i] + values <- data[[nm]] + icon <- get_var_icon(values, "class") + # icon <- if (inherits(values, "character")) { + # phosphoricons::ph("text-aa") + # } else if (inherits(values, "factor")) { + # phosphoricons::ph("list-bullets") + # } else if (inherits(values, c("numeric", "integer"))) { + # phosphoricons::ph("hash") + # } else if (inherits(values, c("Date"))) { + # phosphoricons::ph("calendar") + # } else if (inherits(values, c("POSIXt"))) { + # phosphoricons::ph("clock") + # } else { + # NULL + # } + description <- if (is.atomic(values)) { + paste(i18n("Unique values:"), data.table::uniqueN(values)) + } else { + "" + } + list( + label = htmltools::doRenderTags(tagList( + icon, nm + )), + value = nm, + description = description + ) + } + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//custom_SelectInput.R +######## + +#' A selectizeInput customized for data frames with column labels +#' +#' @description +#' Copied and modified from the IDEAFilter package +#' Adds the option to select "none" which is handled later +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param data \code{data.frame} object from which fields should be populated +#' @param selected default selection +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param col_subset a \code{vector} containing the list of allowable columns to select +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' @param none_label label for "none" item +#' @param maxItems max number of items +#' +#' @return a \code{\link[shiny]{selectizeInput}} dropdown element +#' +#' @importFrom shiny selectizeInput +#' @export +#' +columnSelectInput <- function(inputId, label, data, selected = "", ..., + col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected",maxItems=NULL) { + datar <- if (is.reactive(data)) data else reactive(data) + col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) + + labels <- Map(function(col) { + json <- sprintf( + IDEAFilter:::strip_leading_ws(' + { + "name": "%s", + "label": "%s", + "dataclass": "%s", + "datatype": "%s" + }'), + col, + attr(datar()[[col]], "label") %||% "", + IDEAFilter:::get_dataFilter_class(datar()[[col]]), + data_type(datar()[[col]]) + ) + }, col = names(datar())) + + if (!"none" %in% names(datar())){ + labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',none_label)),labels) + choices <- setNames(names(labels), labels) + choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)] + } else { + choices <- setNames(names(datar()), labels) + choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] + } + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices, + selected = selected, + ..., + options = c( + list(render = I("{ + // format the way that options are rendered + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + + escape(item.data.name) + ' ' + + '' + + (item.data.dataclass != '' ? + ' ' + + item.data.dataclass + + '' : '' ) + ' ' + + (item.data.datatype != '' ? + ' ' + + item.data.datatype + + '' : '' ) + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")), + if (!is.null(maxItems)) list(maxItems=maxItems) + ) + ) +} + + +#' A selectizeInput customized for named vectors +#' +#' @param inputId passed to \code{\link[shiny]{selectizeInput}} +#' @param label passed to \code{\link[shiny]{selectizeInput}} +#' @param choices A named \code{vector} from which fields should be populated +#' @param selected default selection +#' @param ... passed to \code{\link[shiny]{selectizeInput}} +#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options +#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options +#' +#' @returns a \code{\link[shiny]{selectizeInput}} dropdown element +#' @export +#' +#' @examples +#' if (shiny::interactive()) { +#' shinyApp( +#' ui = fluidPage( +#' shiny::uiOutput("select"), +#' tableOutput("data") +#' ), +#' server = function(input, output) { +#' output$select <- shiny::renderUI({ +#' vectorSelectInput( +#' inputId = "variable", label = "Variable:", +#' data = c( +#' "Cylinders" = "cyl", +#' "Transmission" = "am", +#' "Gears" = "gear" +#' ) +#' ) +#' }) +#' +#' output$data <- renderTable( +#' { +#' mtcars[, c("mpg", input$variable), drop = FALSE] +#' }, +#' rownames = TRUE +#' ) +#' } +#' ) +#' } +vectorSelectInput <- function(inputId, + label, + choices, + selected = "", + ..., + placeholder = "", + onInitialize) { + datar <- if (shiny::is.reactive(choices)) data else shiny::reactive(choices) + + labels <- sprintf( + IDEAFilter:::strip_leading_ws(' + { + "name": "%s", + "label": "%s" + }'), + datar(), + names(datar()) %||% "" + ) + + choices_new <- stats::setNames(datar(), labels) + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices_new, + selected = selected, + ..., + options = c( + list(render = I("{ + // format the way that options are rendered + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + + escape(item.data.name) + ' ' + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")) + ) + ) +} + + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//cut-variable-dates.R +######## + +#' Extended cutting function with fall-back to the native base::cut +#' +#' @param x an object inheriting from class "hms" +#' @param ... passed on +#' +#' @export +#' @name cut_var +cut_var <- function(x, ...) { + UseMethod("cut_var") +} + +#' @export +#' @name cut_var +cut_var.default <- function(x, ...) { + base::cut(x, ...) +} + +#' @name cut_var +#' +#' @return factor +#' @export +#' +#' @examples +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(2) +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var("min") +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = "hour") +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) |> cut_var(breaks = hms::as_hms(c("01:00:00", "03:01:20", "9:20:20"))) +#' d_t <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) +#' f <- d_t |> cut_var(2) +#' readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(f)), hms::as_hms(max(d_t, na.rm = TRUE) + 1))), right = FALSE) +cut_var.hms <- function(x, breaks, ...) { + ## as_hms keeps returning warnings on tz(); ignored + suppressWarnings({ + if (hms::is_hms(breaks)) { + breaks <- lubridate::as_datetime(breaks) + } + x <- lubridate::as_datetime(x) + out <- cut_var.POSIXt(x, breaks = breaks, ...) + attr(out, which = "brks") <- hms::as_hms(lubridate::as_datetime(attr(out, which = "brks"))) + attr(out, which = "levels") <- as.character(hms::as_hms(lubridate::as_datetime(attr(out, which = "levels")))) + }) + out +} + +#' @name cut_var +#' @param x an object inheriting from class "POSIXt" or "Date" +#' +#' @examples +#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2) +#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday") +#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only") +#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "%A-%H") +#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "%W") +cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) { + breaks_o <- breaks + args <- list(...) + # browser() + if (is.numeric(breaks)) { + breaks <- quantile( + x, + probs = seq(0, 1, 1 / breaks), + right = right, + include.lowest = include.lowest, + na.rm = TRUE + ) + } + + if ("format" %in% names(args)){ + assertthat::assert_that(is.character(args$format)) + out <- forcats::as_factor(format(x,format=args$format)) + } else if (identical(breaks, "weekday")) { + ## This is + ds <- as.Date(1:7) |> + (\(.x){ + sort_by(format(.x,"%A"),as.numeric(format(.x,"%w"))) + })() + + if (start.on.monday) { + ds <- ds[c(7, 1:6)] + } + out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop() + } else if (identical(breaks, "month_only")) { + ## Simplest way to create a vector of all months in order + ## which will also follow the locale of the machine + ms <- paste0("1970-", 1:12, "-01") |> + as.Date() |> + months() + + out <- factor(months(x), levels = ms) |> forcats::fct_drop() + } else { + ## Doesn't really work very well for breaks other than the special character cases as right border is excluded + out <- base::cut.POSIXt(x, breaks = breaks, right = right, ...) |> forcats::fct_drop() + # browser() + } + l <- levels(out) + if (is.numeric(breaks_o)) { + l <- breaks + } else if (is.character(breaks) && length(breaks) == 1 && !(identical(breaks, "weekday") | identical(breaks, "month_only"))) { + if (include.lowest) { + if (right) { + l <- c(l, min(as.character(x))) + } else { + l <- c(l, max(as.character(x))) + } + } + } else if (length(l) < length(breaks_o)) { + l <- breaks_o + } + + attr(out, which = "brks") <- l + out +} + +#' @name cut_var +#' @param x an object inheriting from class "POSIXct" +cut_var.POSIXct <- cut_var.POSIXt + +#' @name cut_var +#' @param x an object inheriting from class "POSIXct" +#' +#' @examples +#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2) +#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday") +#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(format = "%W") +cut_var.Date <- function(x, breaks=NULL, start.on.monday = TRUE, ...) { + args <- list(...) + + if ("format" %in% names(args)){ + assertthat::assert_that(is.character(args$format)) + out <- forcats::as_factor(format(x,format=args$format)) + } else if (identical(breaks, "weekday")) { + ds <- as.Date(1:7) |> + (\(.x){ + sort_by(format(.x,"%A"),as.numeric(format(.x,"%w"))) + })() + + if (start.on.monday) { + ds <- ds[c(7, 1:6)] + } + out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop() + } else if (identical(breaks, "month_only")) { + ms <- paste0("1970-", 1:12, "-01") |> + as.Date() |> + months() + + out <- factor(months(x), levels = ms) |> forcats::fct_drop() + } else { + ## Doesn't really work very well for breaks other than the special character cases as right border is excluded + out <- base::cut.Date(x, breaks = breaks, ...) |> forcats::fct_drop() + # browser() + } + out +} + +#' Test class +#' +#' @param data data +#' @param class.vec vector of class names to test +#' +#' @return factor +#' @export +#' +#' @examples +#' \dontrun{ +#' vapply(REDCapCAST::redcapcast_data, \(.x){ +#' is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt")) +#' }, logical(1)) +#' } +is_any_class <- function(data, class.vec) { + any(class(data) %in% class.vec) +} + +#' Test is date/datetime/time +#' +#' @param data data +#' +#' @return factor +#' @export +#' +#' @examples +#' vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1)) +is_datetime <- function(data) { + is_any_class(data, class.vec = c("hms", "Date", "POSIXct", "POSIXt")) +} + +#' @title Module to Convert Numeric to Factor +#' +#' @description +#' This module contain an interface to cut a numeric into several intervals. +#' +#' +#' @param id Module ID. +#' +#' @return A [shiny::reactive()] function returning the data. +#' @export +#' +#' @importFrom shiny NS fluidRow column numericInput checkboxInput checkboxInput plotOutput uiOutput +#' @importFrom shinyWidgets virtualSelectInput +#' @importFrom toastui datagridOutput2 +#' +#' @name cut-variable +#' +cut_variable_ui <- function(id) { + ns <- NS(id) + tagList( + shiny::fluidRow( + column( + width = 3, + shinyWidgets::virtualSelectInput( + inputId = ns("variable"), + label = datamods:::i18n("Variable to cut:"), + choices = NULL, + width = "100%" + ) + ), + column( + width = 3, + shiny::uiOutput(ns("cut_method")) + ), + column( + width = 3, + numericInput( + inputId = ns("n_breaks"), + label = datamods:::i18n("Number of breaks:"), + value = 3, + min = 2, + max = 12, + width = "100%" + ) + ), + column( + width = 3, + checkboxInput( + inputId = ns("right"), + label = datamods:::i18n("Close intervals on the right"), + value = TRUE + ), + checkboxInput( + inputId = ns("include_lowest"), + label = datamods:::i18n("Include lowest value"), + value = TRUE + ) + ) + ), + conditionalPanel( + condition = "input.method == 'fixed'", + ns = ns, + uiOutput(outputId = ns("slider_fixed")) + ), + plotOutput(outputId = ns("plot"), width = "100%", height = "270px"), + toastui::datagridOutput2(outputId = ns("count")), + actionButton( + inputId = ns("create"), + label = tagList(phosphoricons::ph("scissors"), datamods:::i18n("Create factor variable")), + class = "btn-outline-primary float-end" + ), + tags$div(class = "clearfix") + ) +} + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' +#' @export +#' +#' @importFrom shiny moduleServer observeEvent reactive req bindEvent renderPlot +#' @importFrom shinyWidgets updateVirtualSelect noUiSliderInput +#' @importFrom toastui renderDatagrid2 datagrid grid_colorbar +#' @importFrom rlang %||% call2 set_names expr syms +#' @importFrom classInt classIntervals +#' +#' @rdname cut-variable +cut_variable_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + rv <- reactiveValues(data = NULL, new_var_name = NULL) + + bindEvent(observe({ + data <- data_r() + rv$data <- data + vars_num <- vapply(data, \(.x){ + is.numeric(.x) || is_datetime(.x) + }, logical(1)) + vars_num <- names(vars_num)[vars_num] + shinyWidgets::updateVirtualSelect( + inputId = "variable", + choices = vars_num, + selected = if (isTruthy(input$variable)) input$variable else vars_num[1] + ) + }), data_r(), input$hidden) + + output$slider_fixed <- renderUI({ + data <- req(data_r()) + variable <- req(input$variable) + req(hasName(data, variable)) + + if (is_datetime(data[[variable]])) { + brks <- cut_var(data[[variable]], + breaks = input$n_breaks + )$brks + } else { + brks <- classInt::classIntervals( + var = data[[variable]], + n = input$n_breaks, + style = "quantile" + )$brks + } + + if (is_datetime(data[[variable]])) { + lower <- min(data[[variable]], na.rm = TRUE) + } else { + lower <- floor(min(data[[variable]], na.rm = TRUE)) + } + + if (is_datetime(data[[variable]])) { + upper <- max(data[[variable]], na.rm = TRUE) + } else { + upper <- ceiling(max(data[[variable]], na.rm = TRUE)) + } + + + shinyWidgets::noUiSliderInput( + inputId = session$ns("fixed_brks"), + label = datamods:::i18n("Fixed breaks:"), + min = lower, + max = upper, + value = brks, + color = datamods:::get_primary_color(), + width = "100%" + ) + }) + + output$cut_method <- renderUI({ + data <- req(data_r()) + variable <- req(input$variable) + + choices <- c( + # "fixed", + # "quantile" + ) + + if (any(c("hms","POSIXct") %in% class(data[[variable]]))) { + choices <- c(choices, "hour") + } else if (any(c("POSIXt", "Date") %in% class(data[[variable]]))) { + choices <- c( + choices, + "day", + "weekday", + "week", + # "week_only", + "month", + "month_only", + "quarter", + "year" + ) + } else { + choices <- c( + choices, + "fixed", + "quantile", + # "sd", + # "equal", + # "pretty", + # "kmeans", + # "hclust", + # "bclust", + # "fisher", + # "jenks", + "headtails" # , + # "maximum", + # "box" + ) + } + + choices <- unique(choices) + + shinyWidgets::virtualSelectInput( + inputId = session$ns("method"), + label = datamods:::i18n("Method:"), + choices = choices, + selected = NULL, + width = "100%" + ) + }) + + + breaks_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + req(hasName(data, variable)) + req(input$n_breaks, input$method) + if (input$method == "fixed") { + req(input$fixed_brks) + if (any(c("hms", "POSIXct") %in% class(data[[variable]]))) { + # cut.POSIXct <- cut.POSIXt + f <- cut_var(data[[variable]], breaks = input$fixed_brks) + list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = "fixed", + fixedBreaks = input$fixed_brks + ) + } + } else if (input$method == "quantile") { + req(input$fixed_brks) + if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) { + # cut.POSIXct <- cut.POSIXt + f <- cut_var(data[[variable]], breaks = input$n_breaks) + list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = "quantile" + ) + } + } else if (input$method %in% c( + "day", + "weekday", + "week", + "month", + "month_only", + "quarter", + "year" + )) { + # To enable datetime cutting + # cut.POSIXct <- cut.POSIXt + f <- cut_var(data[[variable]], breaks = input$method) + list(var = f, brks = levels(f)) + } else if (input$method %in% c("hour")) { + # To enable datetime cutting + # cut.POSIXct <- cut.POSIXt + f <- cut_var(data[[variable]], breaks = "hour") + list(var = f, brks = levels(f)) + # } else if (input$method %in% c("week_only")) { + # # As a proof of concept a single option to use "format" parameter + # # https://www.stat.berkeley.edu/~s133/dates.html + # f <- cut_var(data[[variable]], format = "%W") + # list(var = f, brks = levels(f)) + } else { + classInt::classIntervals( + var = as.numeric(data[[variable]]), + n = input$n_breaks, + style = input$method + ) + } + }) + + output$plot <- renderPlot({ + data <- req(data_r()) + variable <- req(input$variable) + plot_histogram(data, variable, breaks = breaks_r()$brks, color = datamods:::get_primary_color()) + # plot_histogram(data = breaks_r()$var, breaks = breaks_r()$brks, color = datamods:::get_primary_color()) + }) + + + data_cutted_r <- reactive({ + req(input$method) + data <- req(data_r()) + variable <- req(input$variable) + + + if (input$method %in% c("day", "weekday", "week", "month", "month_only", "quarter", "year", "hour")) { + breaks <- input$method + } else { + breaks <- breaks_r()$brks + } + + parameters <- list( + x = data[[variable]], + breaks = breaks, + include.lowest = input$include_lowest, + right = input$right + ) + + new_variable <- tryCatch( + { + rlang::exec(cut_var, !!!parameters) + }, + error = function(err) { + showNotification(paste0("We encountered the following error creating your report: ", err), type = "err") + } + ) + + # new_variable <- do.call( + # cut, + # parameters + # ) + + + data <- append_column(data, column = new_variable, name = paste0(variable, "_cut"), index = "right") + + # setNames(paste0(variable, "_cut")) + # + # data <- dplyr::bind_cols(data, new_variable, .name_repair = "unique_quiet") + + # rv$new_var_name <- names(data)[length(data)] + # browser() + + # browser() + code <- rlang::call2( + "append_column", + !!!list( + column = rlang::call2("cut_var", + !!!modifyList(parameters, list(x = as.symbol(paste0("data$", variable)))), + .ns = "FreesearchR"), + name = paste0(variable, "_cut"), index = "right" + ), + .ns = "FreesearchR" + ) + attr(data, "code") <- code + + # attr(data, "code") <- Reduce( + # f = function(x, y) expr(!!x %>% !!y), + # x = c(attr(data, "code"), code) + # ) + data + }) + + output$count <- toastui::renderDatagrid2({ + # shiny::req(rv$new_var_name) + data <- req(data_cutted_r()) + # variable <- req(input$variable) + count_data <- as.data.frame( + table( + breaks = data[[length(data)]], + useNA = "ifany" + ), + responseName = "count" + ) + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + grid <- toastui::datagrid( + data = count_data, + colwidths = "guess", + theme = "default", + bodyHeight = "auto" + ) + grid <- toastui::grid_columns(grid, className = "font-monospace") + toastui::grid_colorbar( + grid, + column = "count", + label_outside = TRUE, + label_width = "40px", + bar_bg = datamods:::get_primary_color(), + from = c(0, max(count_data$count) + 1) + ) + }) + + data_returned_r <- observeEvent(input$create, { + rv$data <- data_cutted_r() + }) + return(reactive(rv$data)) + } + ) +} + + + +#' @inheritParams shiny::modalDialog +#' @export +#' +#' @importFrom shiny showModal modalDialog textInput +#' @importFrom htmltools tagList +#' +#' @rdname cut-variable +modal_cut_variable <- function(id, + title = datamods:::i18n("Convert Numeric to Factor"), + easyClose = TRUE, + size = "l", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + cut_variable_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + ), + easyClose = easyClose, + size = size, + footer = footer + )) +} + + +#' @importFrom graphics abline axis hist par plot.new plot.window +plot_histogram <- function(data, column=NULL, bins = 30, breaks = NULL, color = "#112466") { + if (is.vector(data)){ + x <- data + } else { + x <- data[[column]] + + } + x <- as.numeric(x) + op <- par(mar = rep(1.5, 4)) + on.exit(par(op)) + plot.new() + plot.window(xlim = range(pretty(x)), ylim = range(pretty(hist(x, breaks = bins, plot = FALSE)$counts))) + abline(v = pretty(x), col = "#D8D8D8") + abline(h = pretty(hist(x, breaks = bins, plot = FALSE)$counts), col = "#D8D8D8") + hist(x, breaks = bins, xlim = range(pretty(x)), xaxs = "i", yaxs = "i", col = color, add = TRUE) + axis(side = 1, at = pretty(x), pos = 0) + axis(side = 2, at = pretty(hist(x, breaks = bins, plot = FALSE)$counts), pos = min(pretty(x))) + abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5) + abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5) +} + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//data_plots.R +######## + +# source(here::here("functions.R")) + +#' Data correlations evaluation module +#' +#' @param id Module id. (Use 'ns("id")') +#' +#' @name data-plots +#' @returns Shiny ui module +#' @export +#' +data_visuals_ui <- function(id, tab_title = "Plots", ...) { + ns <- shiny::NS(id) + + # bslib::navset_bar( + list( + + # Sidebar with a slider input + sidebar = bslib::sidebar( + bslib::accordion( + multiple = FALSE, + bslib::accordion_panel( + title = "Creating plot", + icon = bsicons::bs_icon("graph-up"), + shiny::uiOutput(outputId = ns("primary")), + shiny::helpText('Only non-text variables are available for plotting. Go the "Data" to reclass data to plot.'), + shiny::tags$br(), + shiny::uiOutput(outputId = ns("type")), + shiny::uiOutput(outputId = ns("secondary")), + shiny::uiOutput(outputId = ns("tertiary")), + shiny::br(), + shiny::actionButton( + inputId = ns("act_plot"), + label = "Plot", + width = "100%", + icon = shiny::icon("palette"), + disabled = FALSE + ), + shiny::helpText('Adjust settings, then press "Plot".') + ), + # bslib::accordion_panel( + # title = "Advanced", + # icon = bsicons::bs_icon("gear") + # ), + bslib::accordion_panel( + title = "Download", + icon = bsicons::bs_icon("download"), + shinyWidgets::noUiSliderInput( + inputId = ns("height_slide"), + label = "Plot height (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color(), + inline = TRUE + ), + # shiny::numericInput( + # inputId = ns("height_numeric"), + # label = "Plot height (mm)", + # min = 50, + # max = 300, + # value = 100 + # ), + shinyWidgets::noUiSliderInput( + inputId = ns("width"), + label = "Plot width (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shiny::selectInput( + inputId = ns("plot_type"), + label = "File format", + choices = list( + "png", + "tiff", + "eps", + "pdf", + "jpeg", + "svg" + ) + ), + shiny::br(), + # Button + shiny::downloadButton( + outputId = ns("download_plot"), + label = "Download plot", + icon = shiny::icon("download") + ) + ) + ) + ), + bslib::nav_panel( + title = tab_title, + shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::tags$br(), + shiny::tags$br(), + shiny::htmlOutput(outputId = ns("code_plot")) + ) + ) +} + + +#' +#' @param data data +#' @param ... ignored +#' +#' @name data-plots +#' @returns shiny server module +#' @export +data_visuals_server <- function(id, + data, + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + ns <- session$ns + + rv <- shiny::reactiveValues( + plot.params = NULL, + plot = NULL, + code = NULL + ) + + # ## --- New attempt + # + # rv$plot.params <- shiny::reactive({ + # get_plot_options(input$type) |> purrr::pluck(1) + # }) + # + # c(output, + # list(shiny::renderUI({ + # columnSelectInput( + # inputId = ns("primary"), + # data = data, + # placeholder = "Select variable", + # label = "Response variable", + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$primary) + # # browser() + # + # if (!input$primary %in% names(data())) { + # plot_data <- data()[1] + # } else { + # plot_data <- data()[input$primary] + # } + # + # plots <- possible_plots( + # data = plot_data + # ) + # + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x){ + # stats::setNames(.x$descr, .x$note) + # }) + # + # vectorSelectInput( + # inputId = ns("type"), + # selected = NULL, + # label = shiny::h4("Plot type"), + # choices = Reduce(c, plots_named), + # multiple = FALSE + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # + # cols <- c( + # rv$plot.params()[["secondary.extra"]], + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["secondary.type"]] + # )), + # input$primary + # ) + # ) + # + # columnSelectInput( + # inputId = ns("secondary"), + # data = data, + # selected = cols[1], + # placeholder = "Please select", + # label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable", + # multiple = rv$plot.params()[["secondary.multi"]], + # maxItems = rv$plot.params()[["secondary.max"]], + # col_subset = cols, + # none_label = "No variable" + # ) + # }), + # shiny::renderUI({ + # shiny::req(input$type) + # columnSelectInput( + # inputId = ns("tertiary"), + # data = data, + # placeholder = "Please select", + # label = "Grouping variable", + # multiple = FALSE, + # col_subset = c( + # "none", + # all_but( + # colnames(subset_types( + # data(), + # rv$plot.params()[["tertiary.type"]] + # )), + # input$primary, + # input$secondary + # ) + # ), + # none_label = "No stratification" + # ) + # }) + # )|> setNames(c("primary","type","secondary","tertiary")),keep.null = TRUE) + + + output$primary <- shiny::renderUI({ + shiny::req(data()) + columnSelectInput( + inputId = ns("primary"), + col_subset = names(data())[sapply(data(), data_type) != "text"], + data = data, + placeholder = "Select variable", + label = "Response variable", + multiple = FALSE + ) + }) + + # shiny::observeEvent(data, { + # if (is.null(data()) | NROW(data()) == 0) { + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = TRUE) + # } else { + # shiny::updateActionButton(inputId = ns("act_plot"), disabled = FALSE) + # } + # }) + + + output$type <- shiny::renderUI({ + shiny::req(input$primary) + shiny::req(data()) + # browser() + + if (!input$primary %in% names(data())) { + plot_data <- data()[1] + } else { + plot_data <- data()[input$primary] + } + + plots <- possible_plots( + data = plot_data + ) + + plots_named <- get_plot_options(plots) |> + lapply(\(.x){ + stats::setNames(.x$descr, .x$note) + }) + + vectorSelectInput( + inputId = ns("type"), + selected = NULL, + label = shiny::h4("Plot type"), + choices = Reduce(c, plots_named), + multiple = FALSE + ) + }) + + rv$plot.params <- shiny::reactive({ + get_plot_options(input$type) |> purrr::pluck(1) + }) + + output$secondary <- shiny::renderUI({ + shiny::req(input$type) + + cols <- c( + rv$plot.params()[["secondary.extra"]], + all_but( + colnames(subset_types( + data(), + rv$plot.params()[["secondary.type"]] + )), + input$primary + ) + ) + + columnSelectInput( + inputId = ns("secondary"), + data = data, + selected = cols[1], + placeholder = "Please select", + label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable", + multiple = rv$plot.params()[["secondary.multi"]], + maxItems = rv$plot.params()[["secondary.max"]], + col_subset = cols, + none_label = "No variable" + ) + }) + + output$tertiary <- shiny::renderUI({ + shiny::req(input$type) + columnSelectInput( + inputId = ns("tertiary"), + data = data, + placeholder = "Please select", + label = "Grouping variable", + multiple = FALSE, + col_subset = c( + "none", + all_but( + colnames(subset_types( + data(), + rv$plot.params()[["tertiary.type"]] + )), + input$primary, + input$secondary + ) + ), + none_label = "No stratification" + ) + }) + + shiny::observeEvent(input$act_plot, + { + if (NROW(data()) > 0) { + tryCatch( + { + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary + ) + + shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", { + rv$plot <- rlang::exec(create_plot, !!!append_list(data(), parameters, "data")) + }) + + rv$code <- glue::glue("FreesearchR::create_plot(data,{list2str(parameters)})") + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) + } + }, + ignoreInit = TRUE + ) + + output$code_plot <- shiny::renderUI({ + shiny::req(rv$code) + prismCodeBlock(paste0("#Plotting\n", rv$code)) + }) + + shiny::observeEvent( + list( + data() + ), + { + shiny::req(data()) + + rv$plot <- NULL + } + ) + + output$plot <- shiny::renderPlot({ + # shiny::req(rv$plot) + # rv$plot + if (!is.null(rv$plot)) { + rv$plot + } else { + return(NULL) + } + }) + + # shiny::observeEvent(input$height_numeric, { + # shinyWidgets::updateNoUiSliderInput(session, ns("height_slide"), value = input$height_numeric) + # }, ignoreInit = TRUE) + # shiny::observeEvent(input$height_slide, { + # shiny::updateNumericInput(session, ns("height_numeric"), value = input$height_slide) + # }, ignoreInit = TRUE) + + + output$download_plot <- shiny::downloadHandler( + filename = shiny::reactive({ + paste0("plot.", input$plot_type) + }), + content = function(file) { + if (inherits(rv$plot,"patchwork")){ + plot <- rv$plot + } else if (inherits(rv$plot,"ggplot")){ + plot <- rv$plot + }else { + plot <- rv$plot[[1]] + + } + # browser() + shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", { + ggplot2::ggsave( + filename = file, + plot = plot, + width = input$width, + height = input$height_slide, + dpi = 300, + units = "mm", scale = 2 + ) + }) + } + ) + + + shiny::observe( + return(rv$plot) + ) + } + ) +} + +#' Select all from vector but +#' +#' @param data vector +#' @param ... exclude +#' +#' @returns vector +#' @export +#' +#' @examples +#' all_but(1:10, c(2, 3), 11, 5) +all_but <- function(data, ...) { + data[!data %in% c(...)] +} + +#' Easily subset by data type function +#' +#' @param data data +#' @param types desired types +#' @param type.fun function to get type. Default is outcome_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> subset_types("ordinal") +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical")) +#' #' default_parsing(mtcars) |> subset_types("factor",class) +subset_types <- function(data, types, type.fun = data_type) { + data[sapply(data, type.fun) %in% types] +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - descr: Plot description +#' +#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +#' +#' - secondary.extra: "none" or NULL to have option to choose none. +#' +#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_plots() |> str() +supported_plots <- function() { + list( + plot_hbars = list( + fun = "plot_hbars", + descr = "Stacked horizontal bars", + note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars", + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_violin = list( + fun = "plot_violin", + descr = "Violin plot", + note = "A modern alternative to the classic boxplot to visualise data distribution", + primary.type = c("datatime", "continuous", "dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = "none", + tertiary.type = c("dichotomous", "categorical") + ), + # plot_ridge = list( + # descr = "Ridge plot", + # note = "An alternative option to visualise data distribution", + # primary.type = "continuous", + # secondary.type = c("dichotomous" ,"categorical"), + # tertiary.type = c("dichotomous" ,"categorical"), + # secondary.extra = NULL + # ), + plot_sankey = list( + fun = "plot_sankey", + descr = "Sankey plot", + note = "A way of visualising change between groups", + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + secondary.extra = NULL, + tertiary.type = c("dichotomous", "categorical") + ), + plot_scatter = list( + fun = "plot_scatter", + descr = "Scatter plot", + note = "A classic way of showing the association between to variables", + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ), + plot_box = list( + fun = "plot_box", + descr = "Box plot", + note = "A classic way to plot data distribution by groups", + primary.type = c("datatime", "continuous", "dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = FALSE, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = "none" + ), + plot_euler = list( + fun = "plot_euler", + descr = "Euler diagram", + note = "Generate area-proportional Euler diagrams to display set relationships", + primary.type = c("dichotomous", "categorical"), + secondary.type = c("dichotomous", "categorical"), + secondary.multi = TRUE, + secondary.max = 4, + tertiary.type = c("dichotomous", "categorical"), + secondary.extra = NULL + ) + ) +} + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_plots() +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("mpg") |> +#' possible_plots() +possible_plots <- function(data) { + # browser() + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + type <- data_type(data) + + if (type == "unknown") { + out <- type + } else { + out <- supported_plots() |> + lapply(\(.x){ + if (type %in% .x$primary.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' ls <- mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_plots() |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_plot_options() +get_plot_options <- function(data) { + descrs <- supported_plots() |> + lapply(\(.x){ + .x$descr + }) |> + unlist() + supported_plots() |> + (\(.x){ + .x[match(data, descrs)] + })() +} + + + +#' Wrapper to create plot based on provided type +#' +#' @param data data.frame +#' @param pri primary variable +#' @param sec secondary variable +#' @param ter tertiary variable +#' @param type plot type (derived from possible_plots() and matches custom function) +#' @param ... ignored for now +#' +#' @name data-plots +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, type, pri, sec, ter = NULL, ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } + } + + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } + } + + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + ... + ) + + out <- do.call( + type, + modifyList(parameters,list(data=data)) + ) + + code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR") + + attr(out,"code") <- code + out +} + +#' Print label, and if missing print variable name +#' +#' @param data vector or data frame +#' @param var variable name. Optional. +#' +#' @returns character string +#' @export +#' +#' @examples +#' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() +#' mtcars$mpg |> get_label() +#' gtsummary::trial |> get_label(var = "trt") +#' gtsummary::trial$trt |> get_label() +#' 1:10 |> get_label() +get_label <- function(data, var = NULL) { + # data <- if (is.reactive(data)) data() else data + if (!is.null(var) & is.data.frame(data)) { + data <- data[[var]] + } + out <- REDCapCAST::get_attr(data = data, attr = "label") + if (is.na(out)) { + if (is.null(var)) { + out <- deparse(substitute(data)) + } else { + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } + } + } + out +} + + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data string +#' @param lineLength maximum line length +#' @param fixed flag to force split at exactly the value given in lineLength. +#' Default is FALSE, only splitting at spaces. +#' +#' @returns character string +#' @export +#' +#' @examples +#' "Lorem ipsum... you know the routine" |> line_break() +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, lineLength = 20, force = FALSE) { + if (isTRUE(force)) { + gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) + } else { + paste(strwrap(data, lineLength), collapse = "\n") + } + ## https://stackoverflow.com/a/29847221 +} + + +#' Wrapping +#' +#' @param data list of ggplot2 objects +#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL +#' +#' @returns list of ggplot2 objects +#' @export +#' +wrap_plot_list <- function(data, tag_levels = NULL) { + if (ggplot2::is_ggplot(data[[1]])) { + if (length(data) > 1) { + out <- data |> + (\(.x){ + if (rlang::is_named(.x)) { + purrr::imap(.x, \(.y, .i){ + .y + ggplot2::ggtitle(.i) + }) + } else { + .x + } + })() |> + align_axes() |> + patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect") + if (!is.null(tag_levels)) { + out <- out + patchwork::plot_annotation(tag_levels = tag_levels) + } + } else { + out <- data + } + } else { + cli::cli_abort("Can only wrap lists of {.cls ggplot} objects") + } + out +} + + +#' Aligns axes between plots +#' +#' @param ... ggplot2 objects or list of ggplot2 objects +#' +#' @returns list of ggplot2 objects +#' @export +#' +align_axes <- function(...) { + # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object + # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150 + if (ggplot2::is_ggplot(..1)) { + ## Assumes list of ggplots + p <- list(...) + } else if (is.list(..1)) { + ## Assumes list with list of ggplots + p <- ..1 + } else { + cli::cli_abort("Can only align {.cls ggplot} objects or a list of them") + } + + yr <- clean_common_axis(p, "y") + + xr <- clean_common_axis(p, "x") + + suppressWarnings({ + p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) + }) +} + +#' Extract and clean axis ranges +#' +#' @param p plot +#' @param axis axis. x or y. +#' +#' @returns vector +#' @export +#' +clean_common_axis <- function(p, axis) { + purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |> + unlist() |> + (\(.x){ + if (is.numeric(.x)) { + range(.x) + } else { + as.character(.x) + } + })() |> + unique() +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//data-import.R +######## + +data_import_ui <- function(id) { + ns <- shiny::NS(id) + + shiny::fluidRow( + shiny::column(width = 2), + shiny::column( + width = 8, + shiny::h4("Choose your data source"), + shiny::br(), + shinyWidgets::radioGroupButtons( + inputId = "source", + selected = "env", + choices = c( + "File upload" = "file", + "REDCap server export" = "redcap", + "Local or sample data" = "env" + ), + width = "100%" + ), + shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."), + shiny::br(), + shiny::br(), + shiny::conditionalPanel( + condition = "input.source=='file'", + import_file_ui( + id = ns("file_import"), + layout_params = "dropdown", + title = "Choose a datafile to upload", + file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta") + ) + ), + shiny::conditionalPanel( + condition = "input.source=='redcap'", + m_redcap_readUI(id = ns("redcap_import")) + ), + shiny::conditionalPanel( + condition = "input.source=='env'", + datamods::import_globalenv_ui(id = ns("env"), title = NULL) + ), + shiny::conditionalPanel( + condition = "input.source=='redcap'", + DT::DTOutput(outputId = ns("redcap_prev")) + ) + ) + ) + } + + +data_import_server <- function(id) { + module <- function(input, output, session) { + ns <- session$ns + + rv <- shiny::reactiveValues( + data_temp = NULL, + code = list() + ) + + data_file <- import_file_server( + id = ns("file_import"), + show_data_in = "popup", + trigger_return = "change", + return_class = "data.frame" + ) + + shiny::observeEvent(data_file$data(), { + shiny::req(data_file$data()) + + rv$data_temp <- data_file$data() + rv$code <- append_list(data = data_file$code(), list = rv$code, index = "import") + }) + + data_redcap <- m_redcap_readServer( + id = "redcap_import" + ) + + shiny::observeEvent(data_redcap(), { + # rv$data_original <- purrr::pluck(data_redcap(), "data")() + rv$data_temp <- data_redcap() + }) + + from_env <- datamods::import_globalenv_server( + id = "env", + trigger_return = "change", + btn_show_data = FALSE, + reset = reactive(input$hidden) + ) + + shiny::observeEvent(from_env$data(), { + shiny::req(from_env$data()) + + rv$data_temp <- from_env$data() + # rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import") + }) + + return(list( + # status = reactive(temporary_rv$status), + # name = reactive(temporary_rv$name), + # code = reactive(temporary_rv$code), + data = shiny::reactive(rv$data_temp) + )) + + } + + shiny::moduleServer( + id = id, + module = module + ) + + } + + +#' Test app for the data-import module +#' +#' @rdname data-import +#' +#' @examples +#' \dontrun{ +#' data_import_demo_app() +#' } +data_import_demo_app <- function() { + ui <- shiny::fluidPage( + data_import_ui("data_import"), + toastui::datagridOutput2(outputId = "table"), + DT::DTOutput("data_summary") + ) + server <- function(input, output, session) { + imported <- shiny::reactive(data_import_server(id = "data_import")) + + # output$data_summary <- DT::renderDataTable( + # { + # shiny::req(data_val$data) + # data_val$data + # }, + # options = list( + # scrollX = TRUE, + # pageLength = 5 + # ) + # ) + output$table <- toastui::renderDatagrid2({ + req(imported$data) + toastui::datagrid( + data = head(imported$data, 5), + theme = "striped", + colwidths = "guess", + minBodyHeight = 250 + ) + }) + + } + shiny::shinyApp(ui, server) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//data-summary.R +######## + +#' Data summary module +#' +#' @param id Module id. (Use 'ns("id")') +#' +#' @name data-summary +#' @returns Shiny ui module +#' @export +data_summary_ui <- function(id) { + ns <- NS(id) + + toastui::datagridOutput(outputId = ns("tbl_summary")) +} + + +#' +#' @param data data +#' @param color.main main color +#' @param color.sec secondary color +#' @param ... arguments passed to create_overview_datagrid +#' +#' @name data-summary +#' @returns shiny server module +#' @export +data_summary_server <- function(id, + data, + color.main, + color.sec, + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + ns <- session$ns + + output$tbl_summary <- + toastui::renderDatagrid( + { + shiny::req(data()) + data() |> + overview_vars() |> + create_overview_datagrid(...) |> + add_sparkline( + column = "vals", + color.main = color.main, + color.sec = color.sec + ) + } + ) + + } + ) +} + +#' Add sparkline to datagrid +#' +#' @param grid grid +#' @param column clumn to transform +#' +#' @returns datagrid +#' @export +#' +#' @examples +#' grid <- mtcars |> +#' default_parsing() |> +#' overview_vars() |> +#' toastui::datagrid() |> +#' add_sparkline() +#' grid +add_sparkline <- function(grid, column = "vals", color.main = "#2a8484", color.sec = "#84EF84") { + out <- toastui::grid_sparkline( + grid = grid, + column = column, + renderer = function(data) { + data_cl <- class(data) + if (all(sapply(data,is.na))){ + type <- "line" + ds <- data.frame(x = NA, y = NA) + horizontal <- FALSE + } else if (identical(data_cl, "factor")) { + type <- "column" + s <- summary(data) + ds <- data.frame(x = names(s), y = s) + horizontal <- FALSE + } else if (identical(data_cl, "logical")) { + type <- "column" + s <- table(data) + ds <- data.frame(x = names(s), y = as.vector(s)) + horizontal <- FALSE + } else if (any(c("numeric", "integer") %in% data_cl)) { + if (is_consecutive(data)) { + type <- "line" + ds <- data.frame(x = NA, y = NA) + horizontal <- FALSE + } else { + type <- "box" + ds <- data.frame(x = 1, y = data) + horizontal <- TRUE + } + } else if (any(c("Date", "POSIXct", "POSIXt", "hms", "difftime") %in% data_cl)) { + type <- "line" + ds <- data.frame(x = seq_along(data), y = data) + horizontal <- FALSE + } else { + type <- "line" + ds <- data.frame(x = NA, y = NA) + horizontal <- FALSE + } + apexcharter::apex( + ds, + apexcharter::aes(x, y), + type = type, + auto_update = TRUE + ) |> + apexcharter::ax_chart(sparkline = list(enabled = TRUE)) |> + apexcharter::ax_plotOptions( + boxPlot = apexcharter::boxplot_opts(color.upper = color.sec, color.lower = color.main), + bar = apexcharter::bar_opts(horizontal = horizontal) + ) |> + apexcharter::ax_colors( + c(color.main, color.sec) + ) + } + ) + + toastui::grid_columns( + grid = out, + columns = column, + minWidth = 200 + ) +} + +#' Checks if elements in vector are equally spaced as indication of ID +#' +#' @param data vector +#' +#' @returns logical +#' @export +#' +#' @examples +#' 1:10 |> is_consecutive() +#' sample(1:100,40) |> is_consecutive() +is_consecutive <- function(data){ + suppressWarnings(length(unique(diff(as.numeric(data))))==1) +} + +#' Create a data overview data.frame ready for sparklines +#' +#' @param data data +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' mtcars |> overview_vars() +overview_vars <- function(data) { + data <- as.data.frame(data) + + dplyr::tibble( + icon = get_classes(data), + class = icon, + name = names(data), + n_missing = unname(colSums(is.na(data))), + p_complete = 1 - n_missing / nrow(data), + n_unique = get_n_unique(data), + vals = as.list(data) + ) +} + +#' Create a data overview datagrid +#' +#' @param data data +#' +#' @returns datagrid +#' @export +#' +#' @examples +#' mtcars |> +#' overview_vars() |> +#' create_overview_datagrid() +create_overview_datagrid <- function(data,...) { + # browser() + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + + col.names <- names(data) + + std_names <- c( + "Name" = "name", + "Icon" = "icon", + "Class" = "class", + "Type" = "type", + "Missings" = "n_missing", + "Complete" = "p_complete", + "Unique" = "n_unique", + "Distribution" = "vals" + ) + + headers <- lapply(col.names, \(.x){ + if (.x %in% std_names) { + names(std_names)[match(.x, std_names)] + } else { + .x + } + }) |> unlist() + + grid <- toastui::datagrid( + data = data, + theme = "default", + colwidths = "fit", + ... + ) + + grid <- toastui::grid_columns( + grid = grid, + columns = col.names, + header = headers, + resizable = TRUE + ) + + grid <- toastui::grid_columns( + grid = grid, + columns = "vals", + width = 120 + ) + + grid <- toastui::grid_columns( + grid = grid, + columns = "icon", + header = " ", + align = "center",sortable = FALSE, + width = 40 + ) + + grid <- add_class_icon( + grid = grid, + column = "icon", + fun = class_icons + ) + + grid <- toastui::grid_format( + grid = grid, + "p_complete", + formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}") + ) + + ## This could obviously be extended, which will added even more complexity. + + grid <- toastui::grid_filters( + grid = grid, + column = "name", + # columns = unname(std_names[std_names!="vals"]), + showApplyBtn = FALSE, + showClearBtn = TRUE, + type = "text" + ) + + + return(grid) +} + +#' Convert class grid column to icon +#' +#' @param grid grid +#' @param column column +#' +#' @returns datagrid +#' @export +#' +#' @examples +#' mtcars |> +#' overview_vars() |> +#' toastui::datagrid() |> +#' add_class_icon() +add_class_icon <- function(grid, column = "class", fun=class_icons) { + out <- toastui::grid_format( + grid = grid, + column = column, + formatter = function(value) { + lapply( + X = value, + FUN = fun + ) + } + ) + + toastui::grid_columns( + grid = out, + header = NULL, + columns = column, + width = 60 + ) +} + + +#' Get data class icons +#' +#' @param x character vector of data classes +#' +#' @returns list +#' @export +#' +#' @examples +#' "numeric" |> class_icons()|> str() +#' mtcars |> sapply(class) |> class_icons() |> str() +class_icons <- function(x) { + if (length(x)>1){ + lapply(x,class_icons) + } else { + if (identical(x, "numeric")) { + shiny::icon("calculator") + } else if (identical(x, "factor")) { + shiny::icon("chart-simple") + } else if (identical(x, "integer")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "character")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "logical")) { + shiny::icon("toggle-off") + } else if (any(c("Date", "POSIXt") %in% x)) { + shiny::icon("calendar-days") + } else if (any("POSIXct", "hms") %in% x) { + shiny::icon("clock") + } else { + shiny::icon("table") + }} +} + +#' Get data type icons +#' +#' @param x character vector of data classes +#' +#' @returns list +#' @export +#' +#' @examples +#' "ordinal" |> type_icons() +#' default_parsing(mtcars) |> sapply(data_type) |> type_icons() +type_icons <- function(x) { + if (length(x)>1){ + lapply(x,class_icons) + } else { + if (identical(x, "continuous")) { + shiny::icon("calculator") + } else if (identical(x, "categorical")) { + shiny::icon("chart-simple") + } else if (identical(x, "ordinal")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "text")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "dichotomous")) { + shiny::icon("toggle-off") + } else if (identical(x,"datetime")) { + shiny::icon("calendar-days") + } else if (identical(x,"id")) { + shiny::icon("id-card") + } else { + shiny::icon("table") + } + } +} + +#' Easily get variable icon based on data type or class +#' +#' @param data variable or data frame +#' @param class.type "type" or "class". Default is "class" +#' +#' @returns svg icon +#' @export +#' +#' @examples +#' mtcars[1] |> get_var_icon("class") +#' default_parsing(mtcars) |> get_var_icon() +get_var_icon <- function(data,class.type=c("class","type")){ + if (is.data.frame(data)){ + lapply(data,get_var_icon) + } else { + + class.type <- match.arg(class.type) + + switch(class.type, + type = { + type_icons(data_type(data)) + }, + class = { + class(data)[1] |> class_icons() + } + ) +} + +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//datagrid-infos-mod.R +######## + + +#' Display a table in a window +#' +#' @param data a data object (either a `matrix` or a `data.frame`). +#' @param title Title to be displayed in window. +#' @param show_classes Show variables classes under variables names in table header. +#' @param type Display table in a pop-up with [shinyWidgets::show_alert()], +#' in modal window with [shiny::showModal()] or in a WinBox window with [shinyWidgets::WinBox()]. +#' @param options Arguments passed to [toastui::datagrid()]. +#' @param width Width of the window, only used if `type = "popup"` or `type = "winbox"`. +#' @param ... Additional options, such as `wbOptions = wbOptions()` or `wbControls = wbControls()`. +#' +#' @note +#' If you use `type = "winbox"`, you'll need to use `shinyWidgets::html_dependency_winbox()` somewhere in your UI. +#' +#' @return No value. +#' @export +#' +show_data <- function(data, + title = NULL, + options = NULL, + show_classes = TRUE, + type = c("popup", "modal", "winbox"), + width = "65%", + ...) { # nocov start + type <- match.arg(type) + data <- as.data.frame(data) + args <- list(...) + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + + if (is.null(options)) + options <- list() + + options$height <- 500 + options$minBodyHeight <- 400 + options$data <- data + options$theme <- "default" + options$colwidths <- "guess" + options$guess_colwidths_opts <- list(min_width = 90, max_width = 400, mul = 1, add = 10) + if (isTRUE(show_classes)) + options$summary <- construct_col_summary(data) + datatable <- rlang::exec(toastui::datagrid, !!!options) + datatable <- toastui::grid_columns(datatable, className = "font-monospace") + if (identical(type, "winbox")) { + stopifnot( + "You need shinyWidgets >= 0.8.4" = packageVersion("shinyWidgets") >= "0.8.4" + ) + wb_options <- if (is.null(args$wbOptions)) { + shinyWidgets::wbOptions( + height = "600px", + width = width, + modal = TRUE + ) + } else { + modifyList( + shinyWidgets::wbOptions( + height = "600px", + width = width, + modal = TRUE + ), + args$wbOptions + ) + } + wb_controls <- if (is.null(args$wbControls)) { + shinyWidgets::wbControls() + } else { + args$wbControls + } + shinyWidgets::WinBox( + title = title, + ui = datatable, + options = wb_options, + controls = wb_controls, + padding = "0 5px" + ) + } else if (identical(type, "popup")) { + shinyWidgets::show_alert( + title = NULL, + text = tags$div( + if (!is.null(title)) { + tagList( + tags$h3(title), + tags$hr() + ) + }, + style = "color: #000 !important;", + datatable + ), + closeOnClickOutside = TRUE, + showCloseButton = TRUE, + btn_labels = NA, + html = TRUE, + width = width + ) + } else { + showModal(modalDialog( + title = tagList( + datamods:::button_close_modal(), + title + ), + tags$div( + style = htmltools::css(minHeight = htmltools::validateCssUnit(options$height)), + toastui::renderDatagrid2(datatable) + ), + size = "xl", + footer = NULL, + easyClose = TRUE + )) + } +} # nocov end + + + +#' @importFrom htmltools tagList tags css +describe_col_char <- function(x, with_summary = TRUE) { + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("text-aa"), + "character" + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + datamods:::i18n("Unique:"), length(unique(x)) + ), + tags$div( + datamods:::i18n("Missing:"), sum(is.na(x)) + ), + tags$div( + style = htmltools::css(whiteSpace = "normal", wordBreak = "break-all"), + datamods:::i18n("Most Common:"), gsub( + pattern = "'", + replacement = "\u07F4", + x = names(sort(table(x), decreasing = TRUE))[1] + ) + ), + tags$div( + "\u00A0" + ) + ) + } + ) +} + +fmt_p <- function(val, tot) { + paste0(round(val / tot * 100, 1), "%") +} + +describe_col_factor <- function(x, with_summary = TRUE) { + count <- sort(table(x, useNA = "always"), decreasing = TRUE) + total <- sum(count) + one <- count[!is.na(names(count))][1] + two <- count[!is.na(names(count))][2] + missing <- count[is.na(names(count))] + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("list-bullets"), + "factor" + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + names(one), ":", fmt_p(one, total) + ), + tags$div( + names(two), ":", fmt_p(two, total) + ), + tags$div( + "Missing", ":", fmt_p(missing, total) + ), + tags$div( + "\u00A0" + ) + ) + } + ) +} + +describe_col_num <- function(x, with_summary = TRUE) { + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("hash"), + "numeric" + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + datamods:::i18n("Min:"), round(min(x, na.rm = TRUE), 2) + ), + tags$div( + datamods:::i18n("Mean:"), round(mean(x, na.rm = TRUE), 2) + ), + tags$div( + datamods:::i18n("Max:"), round(max(x, na.rm = TRUE), 2) + ), + tags$div( + datamods:::i18n("Missing:"), sum(is.na(x)) + ) + ) + } + ) +} + + +describe_col_date <- function(x, with_summary = TRUE) { + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("calendar"), + "date" + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + datamods:::i18n("Min:"), min(x, na.rm = TRUE) + ), + tags$div( + datamods:::i18n("Max:"), max(x, na.rm = TRUE) + ), + tags$div( + datamods:::i18n("Missing:"), sum(is.na(x)) + ), + tags$div( + "\u00A0" + ) + ) + } + ) +} + +describe_col_datetime <- function(x, with_summary = TRUE) { + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("clock"), + "datetime" + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + datamods:::i18n("Min:"), min(x, na.rm = TRUE) + ), + tags$div( + datamods:::i18n("Max:"), max(x, na.rm = TRUE) + ), + tags$div( + datamods:::i18n("Missing:"), sum(is.na(x)) + ), + tags$div( + "\u00A0" + ) + ) + } + ) +} + + +describe_col_other <- function(x, with_summary = TRUE) { + tags$div( + style = htmltools::css(padding = "3px 0", fontSize = "x-small"), + tags$div( + style = htmltools::css(fontStyle = "italic"), + get_var_icon(x), + # phosphoricons::ph("clock"), + paste(class(x), collapse = ", ") + ), + if (with_summary) { + tagList( + tags$hr(style = htmltools::css(margin = "3px 0")), + tags$div( + datamods:::i18n("Unique:"), length(unique(x)) + ), + tags$div( + datamods:::i18n("Missing:"), sum(is.na(x)) + ), + tags$div( + "\u00A0" + ), + tags$div( + "\u00A0" + ) + ) + } + ) +} + +construct_col_summary <- function(data) { + list( + position = "top", + height = 90, + columnContent = lapply( + X = setNames(names(data), names(data)), + FUN = function(col) { + values <- data[[col]] + content <- if (inherits(values, "character")) { + describe_col_char(values) + } else if (inherits(values, "factor")) { + describe_col_factor(values) + } else if (inherits(values, c("numeric", "integer"))) { + describe_col_num(values) + } else if (inherits(values, c("Date"))) { + describe_col_date(values) + } else if (inherits(values, c("POSIXt"))) { + describe_col_datetime(values) + } else { + describe_col_other(values) + } + list( + template = toastui::JS( + "function(value) {", + sprintf( + "return '%s';", + gsub(replacement = "", pattern = "\n", x = htmltools::doRenderTags(content)) + ), + "}" + ) + ) + } + ) + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//helpers.R +######## + +#' Wrapper function to get function from character vector referring to function from namespace. Passed to 'do.call()' +#' +#' @description +#' This function follows the idea from this comment: https://stackoverflow.com/questions/38983179/do-call-a-function-in-r-without-loading-the-package +#' @param x function or function name +#' +#' @return function or character vector +#' @export +#' +#' @examples +#' getfun("stats::lm") +getfun <- function(x) { + if ("character" %in% class(x)) { + if (length(grep("::", x)) > 0) { + parts <- strsplit(x, "::")[[1]] + requireNamespace(parts[1]) + getExportedValue(parts[1], parts[2]) + } + } else { + x + } +} + +#' Wrapper to save data in RDS, load into specified qmd and render +#' +#' @param data list to pass to qmd +#' @param ... Passed to `quarto::quarto_render()` +#' +#' @return output file name +#' @export +#' +write_quarto <- function(data, ...) { + # Exports data to temporary location + # + # I assume this is more secure than putting it in the www folder and deleting + # on session end + + # temp <- base::tempfile(fileext = ".rds") + # readr::write_rds(data, file = here) + + readr::write_rds(data, file = "www/web_data.rds") + + ## Specifying a output path will make the rendering fail + ## Ref: https://github.com/quarto-dev/quarto-cli/discussions/4041 + ## Outputs to the same as the .qmd file + quarto::quarto_render( + execute_params = list(data.file = "web_data.rds"), + # execute_params = list(data.file = temp), + ... + ) +} + +write_rmd <- function(data, ..., params.args=NULL) { + # Exports data to temporary location + # + # I assume this is more secure than putting it in the www folder and deleting + # on session end + + # temp <- base::tempfile(fileext = ".rds") + # readr::write_rds(data, file = here) + + readr::write_rds(data, file = "www/web_data.rds") + + ## Specifying a output path will make the rendering fail + ## Ref: https://github.com/quarto-dev/quarto-cli/discussions/4041 + ## Outputs to the same as the .qmd file + rmarkdown::render( + params = modifyList(list(data.file = "web_data.rds",version=app_version()),params.args), + # execute_params = list(data.file = temp), + ... + ) +} + +#' Flexible file import based on extension +#' +#' @param file file name +#' @param consider.na character vector of strings to consider as NAs +#' +#' @return tibble +#' @export +#' +#' @examples +#' read_input("https://raw.githubusercontent.com/agdamsbo/cognitive.index.lookup/main/data/sample.csv") +read_input <- function(file, consider.na = c("NA", '""', "")) { + ext <- tools::file_ext(file) + + if (ext == "csv") { + df <- readr::read_csv(file = file, na = consider.na) + } else if (ext %in% c("xls", "xlsx")) { + df <- readxl::read_excel(file = file, na.strings = consider.na) + } else if (ext == "dta") { + df <- haven::read_dta(file = file) + } else if (ext == "ods") { + df <- readODS::read_ods(path = file) + } else if (ext == "rds") { + df <- readr::read_rds(file = file) + } else { + stop("Input file format has to be on of: + '.csv', '.xls', '.xlsx', '.dta', '.ods' or '.rds'") + } + + df +} + +#' Convert string of arguments to list of arguments +#' +#' @description +#' Idea from the answer: https://stackoverflow.com/a/62979238 +#' +#' @param string string to convert to list to use with do.call +#' +#' @return list +#' @export +#' +#' @examples +#' argsstring2list("A=1:5,b=2:4") +#' +argsstring2list <- function(string) { + eval(parse(text = paste0("list(", string, ")"))) +} + + +#' Factorize variables in data.frame +#' +#' @param data data.frame +#' @param vars variables to force factorize +#' +#' @return data.frame +#' @export +#' +#' @examples +#' factorize(mtcars, names(mtcars)) +factorize <- function(data, vars) { + if (!is.null(vars)) { + data |> + dplyr::mutate( + dplyr::across( + dplyr::all_of(vars), + REDCapCAST::as_factor + ) + ) + } else { + data + } +} + +dummy_Imports <- function() { + list( + MASS::as.fractions(), + broom::augment(), + broom.helpers::all_categorical(), + here::here(), + cardx::all_of(), + parameters::ci(), + DT::addRow(), + bslib::accordion() + ) + # https://github.com/hadley/r-pkgs/issues/828 +} + + +#' Title +#' +#' @param data data +#' @param output.format output +#' @param filename filename +#' @param ... passed on +#' +#' @returns data +#' @export +#' +file_export <- function(data, output.format = c("df", "teal", "list"), filename, ...) { + output.format <- match.arg(output.format) + + filename <- gsub("-", "_", filename) + + if (output.format == "teal") { + out <- within( + teal_data(), + { + assign(name, value |> + dplyr::bind_cols(.name_repair = "unique_quiet") |> + default_parsing()) + }, + value = data, + name = filename + ) + + datanames(out) <- filename + } else if (output.format == "df") { + out <- data |> + default_parsing() + } else if (output.format == "list") { + out <- list( + data = data, + name = filename + ) + + out <- c(out, ...) + } + + out +} + + +#' Default data parsing +#' +#' @param data data +#' +#' @returns data.frame or tibble +#' @export +#' +#' @examples +#' mtcars |> str() +#' mtcars |> +#' default_parsing() |> +#' str() +#' head(starwars, 5) |> str() +#' starwars |> +#' default_parsing() |> +#' head(5) |> +#' str() +default_parsing <- function(data) { + name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label")) + # browser() + out <- data |> + setNames(make.names(names(data), unique = TRUE)) |> + ## Temporary step to avoid nested list and crashing + remove_nested_list() |> + REDCapCAST::parse_data() |> + REDCapCAST::as_factor() |> + REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |> + REDCapCAST::as_logical() |> + REDCapCAST::fct_drop() + + set_column_label(out, setNames(name_labels, names(out)), overwrite = FALSE) + + # purrr::map2( + # out, + # name_labels[names(name_labels) %in% names(out)], + # \(.x, .l){ + # if (!(is.na(.l) | .l == "")) { + # REDCapCAST::set_attr(.x, .l, attr = "label") + # } else { + # attr(x = .x, which = "label") <- NULL + # .x + # } + # # REDCapCAST::set_attr(data = .x, label = .l,attr = "label", overwrite = FALSE) + # } + # ) |> dplyr::bind_cols() +} + +#' Remove empty/NA attributes +#' +#' @param data data +#' +#' @returns data of same class as input +#' @export +#' +#' @examples +#' ds <- mtcars |> +#' lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> +#' dplyr::bind_cols() +#' ds |> +#' remove_empty_attr() |> +#' str() +#' mtcars |> +#' lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> +#' remove_empty_attr() |> +#' str() +#' +remove_empty_attr <- function(data) { + if (is.data.frame(data)) { + data |> + lapply(remove_empty_attr) |> + dplyr::bind_cols() + } else if (is.list(data)) { + data |> lapply(remove_empty_attr) + } else { + attributes(data)[is.na(attributes(data))] <- NULL + data + } +} + +#' Removes columns with completenes below cutoff +#' +#' @param data data frame +#' @param cutoff numeric +#' +#' @returns data frame +#' @export +#' +#' @examples +#' data.frame(a = 1:10, b = NA, c = c(2, NA)) |> remove_empty_cols(cutoff = .5) +remove_empty_cols <- function(data, cutoff = .7) { + filter <- apply(X = data, MARGIN = 2, FUN = \(.x){ + sum(as.numeric(!is.na(.x))) / length(.x) + }) >= cutoff + data[filter] +} + + +#' Append list with named index +#' +#' @param data data to add to list +#' @param list list +#' @param index index name +#' +#' @returns list +#' @export +#' +#' @examples +#' ls_d <- list(test = c(1:20)) +#' ls_d <- list() +#' data.frame(letters[1:20], 1:20) |> append_list(ls_d, "letters") +#' letters[1:20] |> append_list(ls_d, "letters") +append_list <- function(data, list, index) { + ## This will overwrite and not warn + ## Not very safe, but convenient to append code to list + if (index %in% names(list)) { + list[[index]] <- data + out <- list + } else { + out <- setNames(c(list, list(data)), c(names(list), index)) + } + out +} + + +#' Get missingsness fraction +#' +#' @param data data +#' +#' @returns numeric vector +#' @export +#' +#' @examples +#' c(NA, 1:10, rep(NA, 3)) |> missing_fraction() +missing_fraction <- function(data) { + NROW(data[is.na(data)]) / NROW(data) +} + + + +#' Ultra short data dascription +#' +#' @param data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' data.frame( +#' sample(1:8, 20, TRUE), +#' sample(c(1:8, NA), 20, TRUE) +#' ) |> data_description() +data_description <- function(data, data_text = "Data") { + data <- if (shiny::is.reactive(data)) data() else data + + n <- nrow(data) + n_var <- ncol(data) + n_complete <- sum(complete.cases(data)) + p_complete <- n_complete / n + + sprintf( + "%s has %s observations and %s variables, with %s (%s%%) complete cases.", + data_text, + n, + n_var, + n_complete, + signif(100 * p_complete, 3) + ) +} + + +#' Filter function to filter data set by variable type +#' +#' @param data data frame +#' @param type vector of data types (recognised: data_types) +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' default_parsing(mtcars) |> +#' data_type_filter(type = c("categorical", "continuous")) |> +#' attributes() +#' default_parsing(mtcars) |> +#' data_type_filter(type = NULL) |> +#' attributes() +#' \dontrun{ +#' default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous")) +#' } +data_type_filter <- function(data, type) { + ## Please ensure to only provide recognised data types + assertthat::assert_that(all(type %in% names(data_types()))) + + if (!is.null(type)) { + out <- data[data_type(data) %in% type] + code <- rlang::call2("data_type_filter", !!!list(type = type), .ns = "FreesearchR") + attr(out, "code") <- code + } else { + out <- data + } + out +} + +#' Drop-in replacement for the base::sort_by with option to remove NAs +#' +#' @param x x +#' @param y y +#' @param na.rm remove NAs +#' @param ... passed to base_sort_by +#' +#' @returns vector +#' @export +#' +#' @examples +#' sort_by(c("Multivariable", "Univariable"), c("Univariable", "Minimal", "Multivariable")) +sort_by <- function(x, y, na.rm = FALSE, ...) { + out <- base::sort_by(x, y, ...) + if (na.rm == TRUE) { + out[!is.na(out)] + } else { + out + } +} + + +get_ggplot_label <- function(data, label) { + assertthat::assert_that(ggplot2::is_ggplot(data)) + data$labels[[label]] +} + + +#' Return if available +#' +#' @param data vector +#' @param default assigned value for missings +#' +#' @returns vector +#' @export +#' +#' @examples +#' NULL |> if_not_missing("new") +#' c(2, "a", NA) |> if_not_missing() +#' "See" |> if_not_missing() +if_not_missing <- function(data, default = NULL) { + if (length(data) > 1) { + Reduce(c, lapply(data, if_not_missing)) + } else if (is.na(data) || is.null(data)) { + return(default) + } else { + return(data) + } +} + + +#' Merge list of expressions +#' +#' @param data list +#' +#' @returns expression +#' @export +#' +#' @examples +#' list( +#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), +#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") +#' ) |> merge_expression() +merge_expression <- function(data) { + Reduce( + f = function(x, y) rlang::expr(!!x %>% !!y), + x = data + ) +} + +#' Reduce character vector with the native pipe operator or character string +#' +#' @param data list +#' +#' @returns character string +#' @export +#' +#' @examples +#' list( +#' "mtcars", +#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), +#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") +#' ) |> +#' lapply(expression_string) |> +#' pipe_string() |> +#' expression_string("data<-") +pipe_string <- function(data, collapse = "|>\n") { + if (is.list(data)) { + Reduce( + f = function(x, y) glue::glue("{x}{collapse}{y}"), + x = data + ) + } else { + data + } +} + +#' Deparses expression as string, substitutes native pipe and adds assign +#' +#' @param data expression +#' +#' @returns string +#' @export +#' +#' @examples +#' list( +#' as.symbol(paste0("mtcars$", "mpg")), +#' rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), +#' rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") +#' ) |> +#' merge_expression() |> +#' expression_string() +expression_string <- function(data, assign.str = "") { + exp.str <- if (is.call(data)) deparse(data) else data + # browser() + out <- paste0(assign.str, gsub("%>%", "|>\n", paste(gsub('"', "'", paste(exp.str, collapse = "")), collapse = ""))) + gsub(" |`", "", out) +} + + +#' Very simple function to remove nested lists, like when uploading .rds +#' +#' @param data data +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list() +#' dplyr::tibble(a = 1:10, b = rep(list(c("a", "b")), 10)) |> as.data.frame() +remove_nested_list <- function(data) { + data[!sapply(data, is.list)] +} + + + + +#' (Re)label columns in data.frame +#' +#' @param data data.frame to be labelled +#' @param label named list or vector +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' ls <- list("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") +#' ls2 <- c("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") +#' ls3 <- c("mpg" = "", "cyl" = "", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") +#' mtcars |> +#' set_column_label(ls) |> +#' set_column_label(ls2) |> +#' set_column_label(ls3) +#' rlang::expr(FreesearchR::set_column_label(label = !!ls3)) |> expression_string() +set_column_label <- function(data, label, overwrite = TRUE) { + purrr::imap(data, function(.data, .name) { + ls <- if (is.list(label)) unlist(label) else label + ls[ls == ""] <- NA + if (.name %in% names(ls)) { + out <- REDCapCAST::set_attr(.data, unname(ls[.name]), attr = "label", overwrite = overwrite) + remove_empty_attr(out) + } else { + .data + } + }) |> dplyr::bind_cols(.name_repair = "unique_quiet") +} + + +#' Append a column to a data.frame +#' +#' @param data data +#' @param column new column (vector) or data.frame with 1 column +#' @param name new name (pre-fix) +#' @param index desired location. May be "left", "right" or numeric index. +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' mtcars |> +#' dplyr::mutate(mpg_cut = mpg) |> +#' append_column(mtcars$mpg, "mpg_cutter") +append_column <- function(data, column, name, index = "right") { + assertthat::assert_that(NCOL(column) == 1) + assertthat::assert_that(length(index) == 1) + + if (index == "right") { + index <- ncol(data) + 1 + } else if (index == "left") { + index <- 1 + } else if (is.numeric(index)) { + if (index > ncol(data)) { + index <- ncol(data) + 1 + } + } else { + index <- ncol(data) + 1 + } + + ## Identifying potential naming conflicts + nm_conflicts <- names(data)[startsWith(names(data), name)] + ## Simple attemt to create new unique name + if (length(nm_conflicts) > 0) { + name <- glue::glue("{name}_{length(nm_conflicts)+1}") + } + ## If the above not achieves a unique name, the generic approach is used + if (name %in% names(data)) { + name <- make.names(c(name, names(data)), unique = TRUE)[1] + } + new_df <- setNames(data.frame(column), name) + + list( + data[seq_len(index - 1)], + new_df, + if (!index > ncol(data)) data[index:ncol(data)] + ) |> + dplyr::bind_cols() +} + + + +#' Test if element is identical to the previous +#' +#' @param data data. vector, data.frame or list +#' @param no.name logical to remove names attribute before testing +#' +#' @returns logical vector +#' @export +#' +#' @examples +#' c(1, 1, 2, 3, 3, 2, 4, 4) |> is_identical_to_previous() +#' mtcars[c(1, 1, 2, 3, 3, 2, 4, 4)] |> is_identical_to_previous() +#' list(1, 1, list(2), "A", "a", "a") |> is_identical_to_previous() +is_identical_to_previous <- function(data, no.name = TRUE) { + if (is.data.frame(data)) { + lagged <- data.frame(FALSE, data[seq_len(length(data) - 1)]) + } else { + lagged <- c(FALSE, data[seq_len(length(data) - 1)]) + } + + vapply(seq_len(length(data)), \(.x){ + if (isTRUE(no.name)) { + identical(unname(lagged[.x]), unname(data[.x])) + } else { + identical(lagged[.x], data[.x]) + } + }, FUN.VALUE = logical(1)) +} + + +#' Simplified version of the snakecase packages to_snake_case +#' +#' @param data character string vector +#' +#' @returns vector +#' @export +#' +#' @examples +#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake() +simple_snake <- function(data){ + gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R +######## + +hosted_version <- function()'v25.6.3-250626' + + +######## +#### Current file: /Users/au301842/FreesearchR/R//html_dependency_freesearchr.R +######## + +html_dependency_FreesearchR <- function() { + htmltools::htmlDependency( + name = "FreesearchR", + version = packageVersion("FreesearchR"), + src = list(href = "FreesearchR", file = "assets"), + package = "FreesearchR", + stylesheet = "css/FreesearchR.css" + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R +######## + +#' @title Import data from a file +#' +#' @description Let user upload a file and import data +#' +#' @param preview_data Show or not a preview of the data under the file input. +#' @param file_extensions File extensions accepted by [shiny::fileInput()], can also be MIME type. +#' @param layout_params How to display import parameters : in a dropdown button or inline below file input. +#' +#' @export +#' +#' @name import-file +#' +#' +import_file_ui <- function(id, + title = "", + preview_data = TRUE, + file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav"), + layout_params = c("dropdown", "inline")) { + ns <- shiny::NS(id) + + if (!is.null(layout_params)) { + layout_params <- match.arg(layout_params) + } + + if (isTRUE(title)) { + title <- shiny::tags$h4( + datamods:::i18n("Import a file"), + class = "datamods-title" + ) + } + + + params_ui <- shiny::fluidRow( + shiny::column( + width = 6, + shinyWidgets::numericInputIcon( + inputId = ns("skip_rows"), + label = datamods:::i18n("Rows to skip before reading data:"), + value = 0, + min = 0, + icon = list("n ="), + size = "sm", + width = "100%" + ), + shiny::tagAppendChild( + shinyWidgets::textInputIcon( + inputId = ns("na_label"), + label = datamods:::i18n("Missing values character(s):"), + value = "NA,,'',na", + icon = list("NA"), + size = "sm", + width = "100%" + ), + shiny::helpText(phosphoricons::ph("info"), datamods:::i18n("if several use a comma (',') to separate them")) + ) + ), + shiny::column( + width = 6, + shinyWidgets::textInputIcon( + inputId = ns("dec"), + label = datamods:::i18n("Decimal separator:"), + value = ".", + icon = list("0.00"), + size = "sm", + width = "100%" + ), + selectInputIcon( + inputId = ns("encoding"), + label = datamods:::i18n("Encoding:"), + choices = c( + "UTF-8" = "UTF-8", + "Latin1" = "latin1" + ), + icon = phosphoricons::ph("text-aa"), + size = "sm", + width = "100%" + ) + ) + ) + + file_ui <- shiny::tagAppendAttributes( + shiny::fileInput( + inputId = ns("file"), + label = datamods:::i18n("Upload a file:"), + buttonLabel = datamods:::i18n("Browse..."), + placeholder = datamods:::i18n("No file selected; maximum file size is 5 mb"), + accept = file_extensions, + width = "100%", + ## A solution to allow multiple file upload is being considered + multiple = FALSE + ), + class = "mb-0" + ) + if (identical(layout_params, "dropdown")) { + file_ui <- shiny::tags$div( + style = htmltools::css( + display = "grid", + gridTemplateColumns = "1fr 50px", + gridColumnGap = "10px" + ), + file_ui, + shiny::tags$div( + class = "shiny-input-container", + shiny::tags$label( + class = "control-label", + `for` = ns("dropdown_params"), + "...", + style = htmltools::css(visibility = "hidden") + ), + shinyWidgets::dropMenu( + shiny::actionButton( + inputId = ns("dropdown_params"), + label = phosphoricons::ph("gear", title = "Parameters"), + width = "50px", + class = "px-1" + ), + params_ui + ) + ) + ) + } + shiny::tags$div( + class = "datamods-import", + datamods:::html_dependency_datamods(), + title, + file_ui, + if (identical(layout_params, "inline")) params_ui, + shiny::tags$div( + class = "hidden", + id = ns("sheet-container"), + shinyWidgets::pickerInput( + inputId = ns("sheet"), + label = datamods:::i18n("Select sheet to import:"), + choices = NULL, + width = "100%", + multiple = TRUE + ) + ), + shiny::tags$div( + id = ns("import-placeholder"), + shinyWidgets::alert( + id = ns("import-result"), + status = "info", + shiny::tags$b(datamods:::i18n("No file selected:")), + sprintf(datamods:::i18n("You can import %s files"), paste(file_extensions, collapse = ", ")), + dismissible = TRUE + ) + ), + if (isTRUE(preview_data)) { + toastui::datagridOutput2(outputId = ns("table")) + }, + shiny::uiOutput( + outputId = ns("container_confirm_btn"), + style = "margin-top: 20px;" + ), + tags$div( + style = htmltools::css(display = "none"), + shiny::checkboxInput( + inputId = ns("preview_data"), + label = NULL, + value = isTRUE(preview_data) + ) + ) + ) +} + +#' +#' @export +#' +#' +#' @rdname import-file +import_file_server <- function(id, + btn_show_data = TRUE, + show_data_in = c("popup", "modal"), + trigger_return = c("button", "change"), + return_class = c("data.frame", "data.table", "tbl_df", "raw"), + reset = reactive(NULL)) { + read_fns <- list( + ods = "import_ods", + dta = "import_dta", + csv = "import_delim", + tsv = "import_delim", + txt = "import_delim", + xls = "import_xls", + xlsx = "import_xls", + rds = "import_rds" + ) + + trigger_return <- match.arg(trigger_return) + return_class <- match.arg(return_class) + + module <- function(input, output, session) { + ns <- session$ns + imported_rv <- shiny::reactiveValues(data = NULL, name = NULL) + temporary_rv <- shiny::reactiveValues(data = NULL, name = NULL, status = NULL, sheets = 1) + + shiny::observeEvent(reset(), { + temporary_rv$data <- NULL + temporary_rv$name <- NULL + temporary_rv$status <- NULL + }) + + output$container_confirm_btn <- shiny::renderUI({ + if (identical(trigger_return, "button")) { + datamods:::button_import() + } + }) + + shiny::observeEvent(input$file, { + ## Several steps are taken to ensure no errors on changed input file + temporary_rv$sheets <- 1 + if (isTRUE(is_workbook(input$file$datapath))) { + if (isTRUE(is_excel(input$file$datapath))) { + temporary_rv$sheets <- readxl::excel_sheets(input$file$datapath) + } else if (isTRUE(is_ods(input$file$datapath))) { + temporary_rv$sheets <- readODS::ods_sheets(input$file$datapath) + } + selected <- temporary_rv$sheets[1] + + shinyWidgets::updatePickerInput( + session = session, + inputId = "sheet", + selected = selected, + choices = temporary_rv$sheets + ) + datamods:::showUI(paste0("#", ns("sheet-container"))) + } else { + datamods:::hideUI(paste0("#", ns("sheet-container"))) + } + }) + + observeEvent( + list( + input$file, + input$sheet, + input$skip_rows, + input$dec, + input$encoding, + input$na_label + ), + { + req(input$file) + + if (!all(input$sheet %in% temporary_rv$sheets)) { + sheets <- 1 + } else { + sheets <- input$sheet + } + + extension <- tools::file_ext(input$file$datapath) + + parameters <- list( + file = input$file$datapath, + sheet = sheets, + skip = input$skip_rows, + dec = input$dec, + encoding = input$encoding, + na.strings = datamods:::split_char(input$na_label) + ) + + parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(get(read_fns[[extension]])))] + # parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(read_fns[[extension]]))] + imported <- try(rlang::exec(read_fns[[extension]], !!!parameters), silent = TRUE) + code <- rlang::call2(read_fns[[extension]], !!!modifyList(parameters, list(file = input$file$name)), .ns = "FreesearchR") + + if (inherits(imported, "try-error")) { + imported <- try(rlang::exec(rio::import, !!!parameters[1]), silent = TRUE) + code <- rlang::call2("import", !!!list(file = input$file$name), .ns = "rio") + } + + if (inherits(imported, "try-error") || NROW(imported) < 1) { + datamods:::toggle_widget(inputId = "confirm", enable = FALSE) + datamods:::insert_error(mssg = datamods:::i18n(attr(imported, "condition")$message)) + temporary_rv$status <- "error" + temporary_rv$data <- NULL + temporary_rv$name <- NULL + temporary_rv$code <- NULL + } else { + datamods:::toggle_widget(inputId = "confirm", enable = TRUE) + + datamods:::insert_alert( + selector = ns("import"), + status = "success", + datamods:::make_success_alert( + imported, + trigger_return = trigger_return, + btn_show_data = btn_show_data, + extra = if (isTRUE(input$preview_data)) datamods:::i18n("First five rows are shown below:") + ) + ) + temporary_rv$status <- "success" + temporary_rv$data <- imported + temporary_rv$name <- input$file$name + temporary_rv$code <- code + } + }, + ignoreInit = TRUE + ) + + observeEvent(input$see_data, { + tryCatch( + { + datamods:::show_data(default_parsing(temporary_rv$data), title = datamods:::i18n("Imported data"), type = show_data_in) + }, + # warning = function(warn) { + # showNotification(warn, type = "warning") + # }, + error = function(err) { + showNotification(err, type = "err") + } + ) + }) + + output$table <- toastui::renderDatagrid2({ + req(temporary_rv$data) + tryCatch( + { + toastui::datagrid( + data = setNames(head(temporary_rv$data, 5), make.names(names(temporary_rv$data), unique = TRUE)), + theme = "striped", + colwidths = "guess", + minBodyHeight = 250 + ) + }, + error = function(err) { + showNotification(err, type = "err") + } + ) + }) + + observeEvent(input$confirm, { + imported_rv$data <- temporary_rv$data + imported_rv$name <- temporary_rv$name + imported_rv$code <- temporary_rv$code + }) + + if (identical(trigger_return, "button")) { + return(list( + status = reactive(temporary_rv$status), + name = reactive(imported_rv$name), + code = reactive(imported_rv$code), + data = reactive(datamods:::as_out(imported_rv$data, return_class)) + )) + } else { + return(list( + status = reactive(temporary_rv$status), + name = reactive(temporary_rv$name), + code = reactive(temporary_rv$code), + data = reactive(datamods:::as_out(temporary_rv$data, return_class)) + )) + } + } + + moduleServer( + id = id, + module = module + ) +} + +# utils ------------------------------------------------------------------- + +is_excel <- function(path) { + isTRUE(tools::file_ext(path) %in% c("xls", "xlsx")) +} + +is_ods <- function(path) { + isTRUE(tools::file_ext(path) %in% c("ods")) +} + +is_sas <- function(path) { + isTRUE(tools::file_ext(path) %in% c("sas7bdat")) +} + +is_workbook <- function(path) { + is_excel(path) || is_ods(path) +} + + +# File import functions --------------------------------------------------- + +#' Wrapper to ease data file import +#' +#' @param file path to the file +#' @param sheet for Excel files, sheet to read +#' @param skip number of row to skip +#' @param encoding file encoding +#' @param na.strings character(s) to interpret as missing values. +#' +#' +#' @name import-file-type +#' +#' @returns data.frame +#' @export +#' +import_delim <- function(file, skip, encoding, na.strings) { + data.table::fread( + file = file, + na.strings = na.strings, + skip = skip, + check.names = TRUE, + encoding = encoding, + data.table = FALSE, + logical01 = TRUE, + logicalYN = TRUE, + keepLeadingZeros = TRUE + ) +} + + +#' @name import-file-type +#' +#' @returns data.frame +#' @export +#' +import_xls <- function(file, sheet, skip, na.strings) { + tryCatch( + { + ## If sheet is null, this allows purrr::map to run + if (is.null(sheet)) sheet <- 1 + + sheet |> + purrr::map(\(.x){ + readxl::read_excel( + path = file, + sheet = .x, + na = na.strings, + skip = skip, + .name_repair = "unique_quiet", + trim_ws = TRUE + ) + + # openxlsx2::read_xlsx( + # file = file, + # sheet = .x, + # skip_empty_rows = TRUE, + # start_row = skip - 1, + # na.strings = na.strings + # ) + }) |> + purrr::reduce(dplyr::full_join) + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) +} + + +#' @name import-file-type +#' +#' @returns data.frame +#' @export +#' +import_ods <- function(file, sheet, skip, na.strings) { + tryCatch( + { + if (is.null(sheet)) sheet <- 1 + sheet |> + purrr::map(\(.x){ + readODS::read_ods( + path = file, + sheet = .x, + skip = skip, + na = na.strings + ) + }) |> + purrr::reduce(dplyr::full_join) + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) +} + +#' @name import-file-type +#' +#' @returns data.frame +#' @export +#' +import_dta <- function(file) { + haven::read_dta( + file = file, + .name_repair = "unique_quiet" + ) +} + +#' @name import-file-type +#' +#' @returns data.frame +#' @export +#' +import_rds <- function(file) { + readr::read_rds( + file = file + ) +} + +#' @title Create a select input control with icon(s) +#' +#' @description Extend form controls by adding text or icons before, +#' after, or on both sides of a classic `selectInput`. +#' +#' @inheritParams shiny::selectInput +#' +#' @return A numeric input control that can be added to a UI definition. +#' @export +#' +#' @importFrom shiny restoreInput +#' @importFrom htmltools tags validateCssUnit css +#' +selectInputIcon <- function(inputId, + label, + choices, + selected = NULL, + multiple = FALSE, + selectize = TRUE, + size = NULL, + width = NULL, + icon = NULL) { + selected <- shiny::restoreInput(id = inputId, default = selected) + shiny::tags$div( + class = "form-group shiny-input-container", + shinyWidgets:::label_input(inputId, label), + style = htmltools:::css(width = htmltools:::validateCssUnit(width)), + shiny::tags$div( + class = "input-group", + class = shinyWidgets:::validate_size(size), + shinyWidgets:::markup_input_group(icon, "left", theme_func = shiny::getCurrentTheme), + shiny::tags$select( + id = inputId, + class = "form-control select-input-icon", + shiny:::selectOptions(choices, selected, inputId, selectize) + ), + shinyWidgets:::markup_input_group(icon, "right", theme_func = shiny::getCurrentTheme) + ), + shinyWidgets:::html_dependency_input_icons() + ) +} + + +#' Test app for the import_file module +#' +#' @rdname import-file_module +#' +#' @examples +#' \dontrun{ +#' import_file_demo_app() +#' } +import_file_demo_app <- function() { + ui <- shiny::fluidPage( + # theme = bslib::bs_theme(version = 5L), + # theme = bslib::bs_theme(version = 5L, preset = "bootstrap"), + shiny::tags$h3("Import data from a file"), + shiny::fluidRow( + shiny::column( + width = 4, + import_file_ui( + id = "myid", + file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta"), + layout_params = "dropdown" # "inline" # or "dropdown" + ) + ), + shiny::column( + width = 8, + shiny::tags$b("Import status:"), + shiny::verbatimTextOutput(outputId = "status"), + shiny::tags$b("Name:"), + shiny::verbatimTextOutput(outputId = "name"), + shiny::tags$b("Code:"), + shiny::verbatimTextOutput(outputId = "code"), + shiny::tags$b("Data:"), + shiny::verbatimTextOutput(outputId = "data") + ) + ) + ) + server <- function(input, output, session) { + imported <- import_file_server( + id = "myid", + show_data_in = "popup", + trigger_return = "change", + return_class = "data.frame" + ) + + output$status <- shiny::renderPrint({ + imported$status() + }) + output$name <- shiny::renderPrint({ + imported$name() + }) + output$code <- shiny::renderPrint({ + imported$code() + }) + output$data <- shiny::renderPrint({ + imported$data() + }) + } + shiny::shinyApp(ui, server) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//launch_FreesearchR.R +######## + +#' Easily launch the FreesearchR app +#' +#' @description +#' All data.frames in the global environment will be accessible through the app. +#' +#' @param ... passed on to `shiny::runApp()` +#' +#' @returns shiny app +#' @export +#' +#' @examples +#' \dontrun{ +#' data(mtcars) +#' launch_FreesearchR(launch.browser = TRUE) +#' } +launch_FreesearchR <- function(...){ + appDir <- system.file("apps", "FreesearchR", package = "FreesearchR") + if (appDir == "") { + stop("Could not find the app directory. Try re-installing `FreesearchR`.", call. = FALSE) + } + + a <- shiny::runApp(appDir = paste0(appDir,"/app.R"), ...) + return(invisible(a)) +} + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//missings-module.R +######## + +#' Data correlations evaluation module +#' +#' @param id Module id +#' +#' @name data-missings +#' @returns Shiny ui module +#' @export +data_missings_ui <- function(id) { + ns <- shiny::NS(id) + + shiny::tagList( + gt::gt_output(outputId = ns("missings_table")) + ) +} + + +#' +#' @param data data +#' @param output.format output format +#' +#' @name data-missings +#' @returns shiny server module +#' @export +data_missings_server <- function(id, + data, + variable, + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + # ns <- session$ns + + datar <- if (is.reactive(data)) data else reactive(data) + variabler <- if (is.reactive(variable)) variable else reactive(variable) + + rv <- shiny::reactiveValues( + data = NULL, + table = NULL + ) + + rv$data <- shiny::reactive({ + df_tbl <- datar() + by_var <- variabler() + + tryCatch( + { + if (!is.null(by_var) && by_var != "" && by_var %in% names(df_tbl)) { + df_tbl[[by_var]] <- ifelse(is.na(df_tbl[[by_var]]), "Missing", "Non-missing") + + out <- gtsummary::tbl_summary(df_tbl, by = by_var) |> + gtsummary::add_p() + } else { + out <- gtsummary::tbl_summary(df_tbl) + } + }, + error = function(err) { + showNotification(paste0("Error: ", err), type = "err") + } + ) + + out + }) + + output$missings_table <- gt::render_gt({ + shiny::req(datar) + shiny::req(variabler) + + if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) { + if (anyNA(datar())){ + title <- "No variable chosen for analysis" + } else { + title <- "No missing observations" + } + } else { + title <- glue::glue("Missing vs non-missing observations in the variable **'{variabler()}'**") + } + + out <- rv$data() |> + gtsummary::as_gt() |> + gt::tab_header(title = gt::md(title)) + + rv$table <- out + + out + }) + + return(reactive(rv$table)) + } + ) +} + + +missing_demo_app <- function() { + ui <- shiny::fluidPage( + shiny::actionButton( + inputId = "modal_missings", + label = "Browse data", + width = "100%", + disabled = FALSE + ), + shiny::selectInput( + inputId = "missings_var", + label = "Select variable to stratify analysis", choices = c("cyl", "vs") + ), + data_missings_ui("data") + ) + server <- function(input, output, session) { + data_demo <- mtcars + data_demo[sample(1:32, 10), "cyl"] <- NA + data_demo[sample(1:32, 8), "vs"] <- NA + + data_missings_server(id = "data", data = data_demo, variable = shiny::reactive(input$missings_var)) + + visual_summary_server(id = "visual", data = data_demo) + + observeEvent(input$modal_missings, { + tryCatch( + { + modal_visual_summary(id = "visual") + }, + error = function(err) { + showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err") + } + ) + }) + } + shiny::shinyApp(ui, server) +} + +missing_demo_app() + + + + + + + + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_box.R +######## + +#' Beautiful box plot(s) +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") +#' mtcars |> +#' default_parsing() |> +#' plot_box(pri = "mpg", sec = "cyl", ter = "gear") +plot_box <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + plot_box_single( + data = .ds, + pri = pri, + sec = sec + ) + }) + + wrap_plot_list(out) +} + + + + +#' Create nice box-plots +#' +#' @name data-plots +#' +#' @returns ggplot object +#' @export +#' +#' @examples +#' mtcars |> plot_box_single("mpg") +#' mtcars |> plot_box_single("mpg","cyl") +plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { + set.seed(seed) + + if (is.null(sec)) { + sec <- "All" + data[[sec]] <- sec + } + + discrete <- !data_type(data[[sec]]) %in% "continuous" + + data |> + ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) + + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) + + ## THis could be optional in future + ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .2) + + ggplot2::coord_flip() + + viridis::scale_fill_viridis(discrete = discrete, option = "D") + + # ggplot2::theme_void() + + ggplot2::theme_bw(base_size = 24) + + ggplot2::theme( + legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + # text = ggplot2::element_text(size = 20), + # axis.text = ggplot2::element_blank(), + # plot.title = element_blank(), + panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + axis.line = ggplot2::element_line(colour = "black"), + axis.ticks = ggplot2::element_line(colour = "black") + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_euler.R +######## + +#' Area proportional venn diagrams +#' +#' @description +#' THis is slightly modified from https://gist.github.com/danlooo/d23d8bcf8856c7dd8e86266097404ded +#' +#' This functions uses eulerr::euler to plot area proportional venn diagramms +#' but plots it using ggplot2 +#' +#' @param combinations set relationships as a named numeric vector, matrix, or +#' data.frame(See `eulerr::euler`) +#' @param show_quantities whether to show number of intersecting elements +#' @param show_labels whether to show set names +#' @param ... further arguments passed to eulerr::euler +ggeulerr <- function( + combinations, + show_quantities = TRUE, + show_labels = TRUE, + ...) { + # browser() + data <- + eulerr::euler(combinations = combinations, ...) |> + plot(quantities = show_quantities) |> + purrr::pluck("data") + + + tibble::as_tibble(data$ellipses, rownames = "Variables") |> + ggplot2::ggplot() + + ggforce::geom_ellipse( + mapping = ggplot2::aes( + x0 = h, y0 = k, a = a, b = b, angle = 0, fill = Variables + ), + alpha = 0.5, + linewidth = 1.5 + ) + + ggplot2::geom_text( + data = { + data$centers |> + dplyr::mutate( + label = labels |> purrr::map2(quantities, ~ { + if (!is.na(.x) && !is.na(.y) && show_labels) { + paste0(.x, "\n", sprintf(.y, fmt = "%.2g")) + } else if (!is.na(.x) && show_labels) { + .x + } else if (!is.na(.y)) { + .y + } else { + "" + } + }) + ) + }, + mapping = ggplot2::aes(x = x, y = y, label = label), + size = 8 + ) + + ggplot2::theme(panel.grid = ggplot2::element_blank()) + + ggplot2::coord_fixed() + + ggplot2::scale_fill_hue() +} + +#' Easily plot euler diagrams +#' +#' @param data data +#' @param x name of main variable +#' @param y name of secondary variables +#' @param z grouping variable +#' @param seed seed +#' +#' @returns patchwork object +#' @export +#' +#' @examples +#' data.frame( +#' A = sample(c(TRUE, TRUE, FALSE), 50, TRUE), +#' B = sample(c("A", "C"), 50, TRUE), +#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), +#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) +#' ) |> plot_euler("A", c("B", "C"), "D", seed = 4) +#' mtcars |> plot_euler("vs", "am", seed = 1) +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { + set.seed(seed = seed) + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.x){ + .x[c(pri, sec)] |> + as.data.frame() |> + na.omit() |> + plot_euler_single() + }) + + # names(out) + wrap_plot_list(out) + # patchwork::wrap_plots(out, guides = "collect") +} + +#' Easily plot single euler diagrams +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' data.frame( +#' A = sample(c(TRUE, TRUE, FALSE), 50, TRUE), +#' B = sample(c("A", "C"), 50, TRUE), +#' C = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE), +#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) +#' ) |> plot_euler_single() +#' mtcars[c("vs", "am")] |> plot_euler_single() +plot_euler_single <- function(data) { + # if (any("categorical" %in% data_type(data))){ + # shape <- "ellipse" + # } else { + # shape <- "circle" + # } + + data |> + ggeulerr(shape = "circle") + + ggplot2::theme_void() + + ggplot2::theme( + legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + text = ggplot2::element_text(size = 20), + axis.text = ggplot2::element_blank(), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank() + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_hbar.R +######## + +#' Nice horizontal stacked bars (Grotta bars) +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_hbars(pri = "carb", sec = "cyl") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL) +plot_hbars <- function(data, pri, sec, ter = NULL) { + out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) + + out +} + + +#' Vertical stacked bar plot wrapper +#' +#' @param data data.frame +#' @param score outcome variable +#' @param group grouping variable +#' @param strata stratifying variable +#' @param t.size text size +#' +#' @return ggplot2 object +#' @export +#' +vertical_stacked_bars <- function(data, + score = "full_score", + group = "pase_0_q", + strata = NULL, + t.size = 10, + l.color = "black", + l.size = .5, + draw.lines = TRUE) { + if (is.null(group)) { + df.table <- data[c(score, group, strata)] |> + dplyr::mutate("All" = 1) |> + table() + group <- "All" + draw.lines <- FALSE + } else { + df.table <- data[c(score, group, strata)] |> + table() + } + + p <- df.table |> + rankinPlot::grottaBar( + scoreName = score, + groupName = group, + textColor = c("black", "white"), + strataName = strata, + textCut = 6, + textSize = 20, + printNumbers = "none", + lineSize = l.size, + returnData = TRUE + ) + + colors <- viridisLite::viridis(nrow(df.table)) + contrast_cut <- + sum(contrast_text(colors, threshold = .3) == "white") + + score_label <- data |> get_label(var = score) + group_label <- data |> get_label(var = group) + + p |> + (\(.x){ + .x$plot + + ggplot2::geom_text( + data = .x$rectData[which(.x$rectData$n > + 0), ], + size = t.size, + fontface = "plain", + ggplot2::aes( + x = group, + y = p_prev + 0.49 * p, + color = as.numeric(score) > contrast_cut, + # label = paste0(sprintf("%2.0f", 100 * p),"%"), + label = sprintf("%2.0f", 100 * p) + ) + ) + + ggplot2::labs(fill = score_label) + + ggplot2::scale_fill_manual(values = rev(colors)) + + ggplot2::theme( + legend.position = "bottom", + axis.title = ggplot2::element_text(), + ) + + ggplot2::xlab(group_label) + + ggplot2::ylab(NULL) + # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D") + })() +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_ridge.R +######## + +#' Plot nice ridge plot +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' plot_ridge(x = "mpg", y = "cyl") +#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") +plot_ridge <- function(data, x, y, z = NULL, ...) { + if (!is.null(z)) { + ds <- split(data, data[z]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) + + ggridges::geom_density_ridges() + + ggridges::theme_ridges() + + ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa() + }) + + patchwork::wrap_plots(out) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_sankey.R +######## + +#' Readying data for sankey plot +#' +#' @name data-plots +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08))) +#' ds |> sankey_ready("first", "last") +#' ds |> sankey_ready("first", "last", numbers = "percentage") +#' data.frame( +#' g = sample(LETTERS[1:2], 100, TRUE), +#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), +#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) +#' ) |> +#' sankey_ready("first", "last") +sankey_ready <- function(data, pri, sec, numbers = "count", ...) { + ## TODO: Ensure ordering x and y + + ## Ensure all are factors + data[c(pri, sec)] <- data[c(pri, sec)] |> + dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) + + out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec), .drop = FALSE) + + out <- out |> + dplyr::group_by(!!dplyr::sym(pri)) |> + dplyr::mutate(gx.sum = sum(n)) |> + dplyr::ungroup() |> + dplyr::group_by(!!dplyr::sym(sec)) |> + dplyr::mutate(gy.sum = sum(n)) |> + dplyr::ungroup() + + if (numbers == "count") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) + ) + } else if (numbers == "percentage") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) + ) + } + + if (is.factor(data[[pri]])) { + index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n")) + out$lx <- factor(out$lx, levels = levels(out$lx)[index]) + } + + if (is.factor(data[[sec]])) { + index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n")) + out$ly <- factor(out$ly, levels = levels(out$ly)[index]) + } + + out +} + +str_remove_last <- function(data, pattern = "\n") { + strsplit(data, split = pattern) |> + lapply(\(.x)paste(unlist(.x[[-length(.x)]]), collapse = pattern)) |> + unlist() +} + +#' Beautiful sankey plot with option to split by a tertiary group +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey("first", "last") +#' ds |> plot_sankey("first", "last", color.group = "sec") +#' ds |> plot_sankey("first", "last", ter = "g", color.group = "sec") +#' mtcars |> +#' default_parsing() |> +#' plot_sankey("cyl", "gear", "am", color.group = "pri") +#' ## In this case, the last plot as the secondary variable in wrong order +#' ## Dont know why... +#' mtcars |> +#' default_parsing() |> +#' plot_sankey("cyl", "gear", "vs", color.group = "pri") +plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + plot_sankey_single(.ds, pri = pri, sec = sec, color.group = color.group, colors = colors) + }) + + patchwork::wrap_plots(out) +} + +#' Beautiful sankey plot +#' +#' @param color.group set group to colour by. "x" or "y". +#' @param colors optinally specify colors. Give NA color, color for each level +#' in primary group and color for each level in secondary group. +#' @param ... passed to sankey_ready() +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey_single("first", "last") +#' ds |> plot_sankey_single("first", "last", color.group = "sec") +#' data.frame( +#' g = sample(LETTERS[1:2], 100, TRUE), +#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), +#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) +#' ) |> +#' plot_sankey_single("first", "last", color.group = "pri") +#' mtcars |> +#' default_parsing() |> +#' plot_sankey_single("cyl", "vs", color.group = "pri") +plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { + color.group <- match.arg(color.group) + + data_orig <- data + data[c(pri, sec)] <- data[c(pri, sec)] |> + dplyr::mutate(dplyr::across(dplyr::where(is.factor), forcats::fct_drop)) + + # browser() + + data <- data |> sankey_ready(pri = pri, sec = sec, ...) + + na.color <- "#2986cc" + box.color <- "#1E4B66" + + if (is.null(colors)) { + if (color.group == "sec") { + main.colors <- viridisLite::viridis(n = length(levels(data_orig[[sec]]))) + ## Only keep colors for included levels + main.colors <- main.colors[match(levels(data[[sec]]), levels(data_orig[[sec]]))] + + secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + } else { + main.colors <- viridisLite::viridis(n = length(levels(data_orig[[pri]]))) + ## Only keep colors for included levels + main.colors <- main.colors[match(levels(data[[pri]]), levels(data_orig[[pri]]))] + + secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + } + colors <- c(na.color, main.colors, secondary.colors) + } else { + label.colors <- contrast_text(colors) + } + + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + sapply(line_break) |> + unname() + + p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + + if (color.group == "sec") { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes( + fill = !!dplyr::sym(sec) # , + ## Including will print strings when levels are empty + # color = !!dplyr::sym(sec) + ), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), + size = 2, + width = 1 / 3.4 + ) + } else { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes( + fill = !!dplyr::sym(pri) # , + # color = !!dplyr::sym(pri) + ), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), + size = 2, + width = 1 / 3.4 + ) + } + + ## Will fail to use stat="stratum" if library is not loaded. + library(ggalluvial) + p + + ggplot2::geom_text( + stat = "stratum", + ggplot2::aes(label = after_stat(stratum)), + colour = label.colors, + size = 8, + lineheight = 1 + ) + + ggplot2::scale_x_continuous( + breaks = 1:2, + labels = group_labels + ) + + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + + # ggplot2::scale_color_manual(values = main.colors) + + ggplot2::theme_void() + + ggplot2::theme( + legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + axis.text.x = ggplot2::element_text(size = 20), + # text = element_text(size = 5), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank() + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_scatter.R +######## + +#' Beautiful violin plot +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") +plot_scatter <- function(data, pri, sec, ter = NULL) { + if (is.null(ter)) { + rempsyc::nice_scatter( + data = data, + predictor = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) + ) + } else { + rempsyc::nice_scatter( + data = data, + predictor = sec, + response = pri, + group = ter, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) + ) + } +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot_violin.R +######## + +#' Beatiful violin plot +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +plot_violin <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + rempsyc::nice_violin( + data = .ds, + group = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) + ) + }) + + wrap_plot_list(out) + # patchwork::wrap_plots(out,guides = "collect") +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//plot-download-module.R +######## + +plot_download_ui <- regression_ui <- function(id, ...) { + ns <- shiny::NS(id) + + shiny::tagList( + shinyWidgets::noUiSliderInput( + inputId = ns("plot_height"), + label = "Plot height (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shinyWidgets::noUiSliderInput( + inputId = ns("plot_width"), + label = "Plot width (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shiny::selectInput( + inputId = ns("plot_type"), + label = "File format", + choices = list( + "png", + "tiff", + "eps", + "pdf", + "jpeg", + "svg" + ) + ), + shiny::br(), + # Button + shiny::downloadButton( + outputId = ns("download_plot"), + label = "Download plot", + icon = shiny::icon("download") + ) + ) +} + +plot_download_server <- function(id, + data, + file_name = "reg_plot", + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + # ns <- session$ns + + + + output$download_plot <- shiny::downloadHandler( + filename = paste0(file_name, ".", input$plot_type), + content = function(file) { + shiny::withProgress(message = "Saving the plot. Hold on for a moment..", { + ggplot2::ggsave( + filename = file, + plot = data, + width = input$plot_width, + height = input$plot_height, + dpi = 300, + units = "mm", scale = 2 + ) + }) + } + ) + } + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//redcap_read_shiny_module.R +######## + +#' Shiny module to browser and export REDCap data +#' +#' @param id Namespace id +#' @param include_title logical to include title +#' +#' @rdname redcap_read_shiny_module +#' +#' @return shiny ui element +#' @export +m_redcap_readUI <- function(id, title = TRUE, url = NULL) { + ns <- shiny::NS(id) + + if (isTRUE(title)) { + title <- shiny::tags$h4( + "Import data from REDCap", + class = "redcap-module-title" + ) + } + + server_ui <- shiny::tagList( + shiny::tags$h4("REDCap server"), + shiny::textInput( + inputId = ns("uri"), + label = "Web address", + value = if_not_missing(url, "https://redcap.your.institution/"), + width = "100%" + ), + shiny::helpText("Format should be either 'https://redcap.your.institution/' or 'https://your.institution/redcap/'"), + # shiny::textInput( + # inputId = ns("api"), + # label = "API token", + # value = "", + # width = "100%" + # ), + shiny::passwordInput( + inputId = ns("api"), + label = "API token", + value = "", + width = "100%" + ), + shiny::helpText("The token is a string of 32 numbers and letters."), + shiny::br(), + shiny::br(), + shiny::actionButton( + inputId = ns("data_connect"), + label = "Connect", + icon = shiny::icon("link", lib = "glyphicon"), + width = "100%", + disabled = TRUE + ), + shiny::br(), + shiny::br(), + tags$div( + id = ns("connect-placeholder"), + shinyWidgets::alert( + id = ns("connect-result"), + status = "info", + tags$p(phosphoricons::ph("info", weight = "bold"), "Please fill in server address (URI) and API token, then press 'Connect'.") + ), + dismissible = TRUE + ), + shiny::br() + ) + + filter_ui <- + shiny::tagList( + # width = 6, + shiny::uiOutput(outputId = ns("arms")), + shiny::textInput( + inputId = ns("filter"), + label = "Optional filter logic (e.g., ⁠[gender] = 'female')" + ) + ) + + params_ui <- + shiny::tagList( + shiny::tags$h4("Data import parameters"), + shiny::tags$div( + style = htmltools::css( + display = "grid", + gridTemplateColumns = "1fr 50px", + gridColumnGap = "10px" + ), + shiny::uiOutput(outputId = ns("fields")), + shiny::tags$div( + class = "shiny-input-container", + shiny::tags$label( + class = "control-label", + `for` = ns("dropdown_params"), + "...", + style = htmltools::css(visibility = "hidden") + ), + shinyWidgets::dropMenu( + shiny::actionButton( + inputId = ns("dropdown_params"), + label = shiny::icon("filter"), + width = "50px" + ), + filter_ui + ) + ) + ), + shiny::helpText("Select fields/variables to import and click the funnel to apply optional filters"), + shiny::tags$br(), + shiny::tags$br(), + shiny::uiOutput(outputId = ns("data_type")), + shiny::uiOutput(outputId = ns("fill")), + shiny::actionButton( + inputId = ns("data_import"), + label = "Import", + icon = shiny::icon("download", lib = "glyphicon"), + width = "100%", + disabled = TRUE + ), + shiny::tags$br(), + shiny::tags$br(), + tags$div( + id = ns("retrieved-placeholder"), + shinyWidgets::alert( + id = ns("retrieved-result"), + status = "info", + tags$p(phosphoricons::ph("info", weight = "bold"), "Please specify data to download, then press 'Import'.") + ), + dismissible = TRUE + ) + ) + + + shiny::fluidPage( + title = title, + server_ui, + # shiny::uiOutput(ns("params_ui")), + shiny::conditionalPanel( + condition = "output.connect_success == true", + params_ui, + ns = ns + ), + shiny::br() + ) +} + + +#' @rdname redcap_read_shiny_module +#' +#' @return shiny server module +#' @export +#' +m_redcap_readServer <- function(id) { + module <- function(input, output, session) { + ns <- session$ns + + data_rv <- shiny::reactiveValues( + dd_status = NULL, + data_status = NULL, + uri = NULL, + project_name = NULL, + info = NULL, + arms = NULL, + dd_list = NULL, + data = NULL, + rep_fields = NULL, + code = NULL + ) + + shiny::observeEvent(list(input$api, input$uri), { + shiny::req(input$api) + shiny::req(input$uri) + if (!is.null(input$uri)) { + uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/") + } else { + uri <- input$uri + } + + if (is_valid_redcap_url(uri) & is_valid_token(input$api)) { + data_rv$uri <- uri + shiny::updateActionButton(inputId = "data_connect", disabled = FALSE) + } else { + shiny::updateActionButton(inputId = "data_connect", disabled = TRUE) + } + }) + + + tryCatch( + { + shiny::observeEvent( + list( + input$data_connect + ), + { + shiny::req(input$api) + shiny::req(data_rv$uri) + + parameters <- list( + redcap_uri = data_rv$uri, + token = input$api + ) + + # browser() + shiny::withProgress( + { + imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) + }, + message = paste("Connecting to", data_rv$uri) + ) + + ## TODO: Simplify error messages + if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + if (ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { + mssg <- imported$raw_text + } else { + mssg <- attr(imported, "condition")$message + } + + datamods:::insert_error(mssg = mssg, selector = "connect") + data_rv$dd_status <- "error" + data_rv$dd_list <- NULL + } else if (isTRUE(imported$success)) { + data_rv$dd_status <- "success" + + data_rv$info <- REDCapR::redcap_project_info_read( + redcap_uri = data_rv$uri, + token = input$api + )$data + + datamods:::insert_alert( + selector = ns("connect"), + status = "success", + include_data_alert( + see_data_text = "Click to see data dictionary", + dataIdName = "see_dd", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), + glue::glue("The {data_rv$info$project_title} project is loaded.") + ), + btn_show_data = TRUE + ) + ) + + data_rv$dd_list <- imported + } + }, + ignoreInit = TRUE + ) + }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) + + output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) + shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) + + + shiny::observeEvent(input$see_dd, { + show_data( + purrr::pluck(data_rv$dd_list, "data"), + title = "Data dictionary", + type = "modal", + show_classes = FALSE, + tags$b("Preview:") + ) + }) + + shiny::observeEvent(input$see_data, { + show_data( + # purrr::pluck(data_rv$dd_list, "data"), + data_rv$data, + title = "Imported data set", + type = "modal", + show_classes = FALSE, + tags$b("Preview:") + ) + }) + + arms <- shiny::reactive({ + shiny::req(input$api) + shiny::req(data_rv$uri) + + REDCapR::redcap_event_read( + redcap_uri = data_rv$uri, + token = input$api + )$data + }) + + output$fields <- shiny::renderUI({ + shiny::req(data_rv$dd_list) + shinyWidgets::virtualSelectInput( + inputId = ns("fields"), + label = "Select fields/variables to import:", + choices = purrr::pluck(data_rv$dd_list, "data") |> + dplyr::select(field_name, form_name) |> + (\(.x){ + split(.x$field_name, REDCapCAST::as_factor(.x$form_name)) + })(), + updateOn = "change", + multiple = TRUE, + search = TRUE, + showValueAsTags = TRUE, + width = "100%" + ) + }) + + output$data_type <- shiny::renderUI({ + shiny::req(data_rv$info) + if (isTRUE(data_rv$info$has_repeating_instruments_or_events)) { + vectorSelectInput( + inputId = ns("data_type"), + label = "Specify the data format", + choices = c( + "Wide data (One row for each subject)" = "wide", + "Long data for project with repeating instruments (default REDCap)" = "long" + ), + selected = "wide", + multiple = FALSE, + width = "100%" + ) + } + }) + + output$fill <- shiny::renderUI({ + shiny::req(data_rv$info) + shiny::req(input$data_type) + + ## Get repeated field + data_rv$rep_fields <- data_rv$dd_list$data$field_name[ + data_rv$dd_list$data$form_name %in% repeated_instruments( + uri = data_rv$uri, + token = input$api + ) + ] + + if (input$data_type == "long" && isTRUE(any(input$fields %in% data_rv$rep_fields))) { + vectorSelectInput( + inputId = ns("fill"), + label = "Fill missing values?", + choices = c( + "Yes, fill missing, non-repeated values" = "yes", + "No, leave the data as is" = "no" + ), + selected = "no", + multiple = FALSE, + width = "100%" + ) + } + }) + + shiny::observeEvent(input$fields, { + if (is.null(input$fields) | length(input$fields) == 0) { + shiny::updateActionButton(inputId = "data_import", disabled = TRUE) + } else { + shiny::updateActionButton(inputId = "data_import", disabled = FALSE) + } + }) + + output$arms <- shiny::renderUI({ + if (NROW(arms()) > 0) { + vectorSelectInput( + inputId = ns("arms"), + selected = NULL, + label = "Filter by events/arms", + choices = stats::setNames(arms()[[3]], arms()[[1]]), + multiple = TRUE, + width = "100%" + ) + } + }) + + shiny::observeEvent(input$data_import, { + shiny::req(input$fields) + + # browser() + record_id <- purrr::pluck(data_rv$dd_list, "data")[[1]][1] + + + parameters <- list( + uri = data_rv$uri, + token = input$api, + fields = unique(c(record_id, input$fields)), + events = input$arms, + raw_or_label = "both", + filter_logic = input$filter, + split_forms = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "none", + "all" + ) + ) + + shiny::withProgress(message = "Downloading REDCap data. Hold on for a moment..", { + imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) + }) + + parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")] + + code <- rlang::call2( + "easy_redcap", + !!!utils::modifyList( + parameters_code, + list( + data_format = ifelse( + input$data_type == "long" && !is.null(input$data_type), + "long", + "wide" + ), + project.name = simple_snake(data_rv$info$project_title) + ) + ), + .ns = "REDCapCAST" + ) + + if (inherits(imported, "try-error") || NROW(imported) < 1) { + data_rv$data_status <- "error" + data_rv$data_list <- NULL + data_rv$data_message <- imported$raw_text + } else { + data_rv$data_status <- "success" + data_rv$data_message <- "Requested data was retrieved!" + + ## The data management below should be separated to allow for changing + ## "wide"/"long" without re-importing data + + if (parameters$split_form == "all") { + # browser() + out <- imported |> + # redcap_wider() + REDCapCAST::redcap_wider() + } else { + if (input$fill == "yes") { + ## Repeated fields + + + ## Non-repeated fields in current dataset + inc_non_rep <- names(imported)[!names(imported) %in% data_rv$rep_fields] + + out <- imported |> + drop_empty_event() |> + dplyr::group_by(!!dplyr::sym(names(imported)[1])) |> + tidyr::fill(inc_non_rep) |> + dplyr::ungroup() + } else { + out <- imported |> + drop_empty_event() + } + } + + # browser() + in_data_check <- parameters$fields %in% names(out) | + sapply(names(out), \(.x) any(sapply(parameters$fields, \(.y) startsWith(.x, .y)))) + + if (!any(in_data_check[-1])) { + data_rv$data_status <- "warning" + data_rv$data_message <- "Data retrieved, but it looks like only the ID was retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + } + + if (!all(in_data_check)) { + data_rv$data_status <- "warning" + data_rv$data_message <- "Data retrieved, but it looks like not all requested fields were retrieved from the server. Please check with your REDCap administrator that you have required permissions for data access." + } + + data_rv$code <- code + + data_rv$data <- out |> + dplyr::select(-dplyr::ends_with("_complete")) |> + # dplyr::select(-dplyr::any_of(record_id)) |> + REDCapCAST::suffix2label() + } + }) + + shiny::observeEvent( + data_rv$data_status, + { + # browser() + if (identical(data_rv$data_status, "error")) { + datamods:::insert_error(mssg = data_rv$data_message, selector = ns("retrieved")) + } else if (identical(data_rv$data_status, "success")) { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + # tags$p( + # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), + # data_rv$data_message + # ), + include_data_alert( + see_data_text = "Click to see the imported data", + dataIdName = "see_data", + extra = tags$p( + tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message) + ), + btn_show_data = TRUE + ) + ) + } else { + datamods:::insert_alert( + selector = ns("retrieved"), + status = data_rv$data_status, + tags$p( + tags$b(phosphoricons::ph("warning", weight = "bold"), "Warning!"), + data_rv$data_message + ) + ) + } + } + ) + + return(list( + status = shiny::reactive(data_rv$data_status), + name = shiny::reactive(data_rv$info$project_title), + info = shiny::reactive(data_rv$info), + code = shiny::reactive(data_rv$code), + data = shiny::reactive(data_rv$data) + )) + } + + shiny::moduleServer( + id = id, + module = module + ) +} + +#' @importFrom htmltools tagList tags +#' @importFrom shiny icon getDefaultReactiveDomain +include_data_alert <- function(dataIdName = "see_data", + btn_show_data, + see_data_text = "Click to see data", + extra = NULL, + session = shiny::getDefaultReactiveDomain()) { + if (isTRUE(btn_show_data)) { + success_message <- tagList( + extra, + tags$br(), + shiny::actionLink( + inputId = session$ns(dataIdName), + label = tagList(phosphoricons::ph("book-open-text"), see_data_text) + ) + ) + } + return(success_message) +} + +# #' REDCap import teal data module +# #' +# #' @rdname redcap_read_shiny_module +# tdm_redcap_read <- teal::teal_data_module( +# ui <- function(id) { +# shiny::fluidPage( +# m_redcap_readUI(id) +# ) +# }, +# server = function(id) { +# m_redcap_readServer(id, output.format = "teal") +# } +# ) + + +#' Test if url is valid format for REDCap API +#' +#' @param url url +#' +#' @returns logical +#' @export +#' +#' @examples +#' url <- c( +#' "www.example.com", +#' "redcap.your.inst/api/", +#' "https://redcap.your.inst/api/", +#' "https://your.inst/redcap/api/", +#' "https://www.your.inst/redcap/api/" +#' ) +#' is_valid_redcap_url(url) +is_valid_redcap_url <- function(url) { + pattern <- "https://[^ /$.?#].[^\\s]*/api/$" + stringr::str_detect(url, pattern) +} + +#' Validate REDCap token +#' +#' @param token token +#' @param pattern_env pattern +#' +#' @returns logical +#' @export +#' +#' @examples +#' token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") +#' is_valid_token(token) +is_valid_token <- function(token, pattern_env = NULL, nchar = 32) { + checkmate::assert_character(token, any.missing = TRUE, len = 1) + + if (!is.null(pattern_env)) { + checkmate::assert_character(pattern_env, + any.missing = FALSE, + len = 1 + ) + pattern <- pattern_env + } else { + pattern <- glue::glue("^([0-9A-Fa-f]{})(?:\\n)?$", + .open = "<", + .close = ">" + ) + } + + if (is.na(token)) { + out <- FALSE + } else if (is.null(token)) { + out <- FALSE + } else if (nchar(token) == 0L) { + out <- FALSE + } else if (!grepl(pattern, token, perl = TRUE)) { + out <- FALSE + } else { + out <- TRUE + } + out +} + +#' Get names of repeated instruments +#' +#' @param uri REDCap database uri +#' @param token database token +#' +#' @returns vector +#' @export +#' +repeated_instruments <- function(uri, token) { + instruments <- REDCapR::redcap_event_instruments(redcap_uri = uri, token = token) + unique(instruments$data$form[duplicated(instruments$data$form)]) +} + +#' Drop empty events from REDCap export +#' +#' @param data data +#' @param event "redcap_event_name", "redcap_repeat_instrument" or +#' "redcap_repeat_instance" +#' +#' @returns data.frame +#' @export +#' +drop_empty_event <- function(data, event = "redcap_event_name") { + generics <- c(names(data)[1], "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance") + + filt <- split(data, data[[event]]) |> + lapply(\(.x){ + dplyr::select(.x, -tidyselect::all_of(generics)) |> + REDCapCAST::all_na() + }) |> + unlist() + + data[data[[event]] %in% names(filt)[!filt], ] +} + + +#' Test app for the redcap_read_shiny_module +#' +#' @rdname redcap_read_shiny_module +#' +#' @examples +#' \dontrun{ +#' redcap_demo_app() +#' } +redcap_demo_app <- function() { + ui <- shiny::fluidPage( + m_redcap_readUI("data", url = NULL), + DT::DTOutput("data"), + shiny::tags$b("Code:"), + shiny::verbatimTextOutput(outputId = "code") + ) + server <- function(input, output, session) { + data_val <- m_redcap_readServer(id = "data") + + output$data <- DT::renderDataTable( + { + shiny::req(data_val$data) + data_val$data() + }, + options = list( + scrollX = TRUE, + pageLength = 5 + ), + ) + output$code <- shiny::renderPrint({ + shiny::req(data_val$code) + data_val$code() + }) + } + shiny::shinyApp(ui, server) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//regression_model.R +######## + +#' Create a regression model programatically +#' +#' @param data data set +#' @param fun Name of function as character vector or function to use for model creation. +#' @param vars character vector of variables to include +#' @param outcome.str Name of outcome variable. Character vector. +#' @param auto.mode Make assumptions on function dependent on outcome data format. Overwrites other arguments. +#' @param formula.str Formula as string. Passed through 'glue::glue'. If given, 'outcome.str' and 'vars' are ignored. Optional. +#' @param args.list List of arguments passed to 'fun' with 'do.call'. +#' @param ... ignored for now +#' +#' @importFrom stats as.formula +#' +#' @return object of standard class for fun +#' @export +#' @rdname regression_model +#' +#' @examples +#' gtsummary::trial |> +#' regression_model(outcome.str = "age") +#' gtsummary::trial |> +#' regression_model( +#' outcome.str = "age", +#' auto.mode = FALSE, +#' fun = "stats::lm", +#' formula.str = "{outcome.str}~.", +#' args.list = NULL +#' ) +#' gtsummary::trial |> +#' default_parsing() |> +#' regression_model( +#' outcome.str = "trt", +#' auto.mode = FALSE, +#' fun = "stats::glm", +#' args.list = list(family = binomial(link = "logit")) +#' ) +#' m <- mtcars |> +#' default_parsing() |> +#' regression_model( +#' outcome.str = "mpg", +#' auto.mode = FALSE, +#' fun = "stats::lm", +#' formula.str = "{outcome.str}~{paste(vars,collapse='+')}", +#' args.list = NULL, +#' vars = c("mpg", "cyl") +#' ) +#' broom::tidy(m) +regression_model <- function(data, + outcome.str = NULL, + auto.mode = FALSE, + formula.str = NULL, + args.list = NULL, + fun = NULL, + vars = NULL, + ...) { + if (!is.null(formula.str)) { + if (formula.str == "") { + formula.str <- NULL + } + } + + ## This will handle if outcome is not in data for nicer shiny behavior + if (isTRUE(!outcome.str %in% names(data))) { + outcome.str <- names(data)[1] + print("Outcome variable is not in data, first column is used") + } + + if (!is.null(formula.str)) { + formula.glue <- glue::glue(formula.str) + outcome.str <- NULL + } else { + assertthat::assert_that(outcome.str %in% names(data), + msg = "Outcome variable is not present in the provided dataset" + ) + formula.glue <- glue::glue("{outcome.str}~{paste(vars,collapse='+')}") + } + + if (is.null(vars)) { + vars <- names(data)[!names(data) %in% outcome.str] + } else if (!is.null(outcome.str)) { + if (outcome.str %in% vars) { + vars <- vars[!vars %in% outcome.str] + } + data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str))) + } + + # Formatting character variables as factor + # Improvement should add a missing vector to format as NA + data <- data |> + purrr::map(\(.x){ + if (is.character(.x)) { + suppressWarnings(REDCapCAST::as_factor(.x)) + } else { + .x + } + }) |> + dplyr::bind_cols(.name_repair = "unique_quiet") + + if (is.null(fun)) auto.mode <- TRUE + + if (isTRUE(auto.mode)) { + if (is.numeric(data[[outcome.str]])) { + fun <- "stats::lm" + } else if (is.factor(data[[outcome.str]])) { + if (length(levels(data[[outcome.str]])) == 2) { + fun <- "stats::glm" + args.list <- list(family = stats::binomial(link = "logit")) + } else if (length(levels(data[[outcome.str]])) > 2) { + fun <- "MASS::polr" + args.list <- list( + Hess = TRUE, + method = "logistic" + ) + } else { + stop("The provided output variable only has one level") + } + } else { + stop("Output variable should be either numeric or factor for auto.mode") + } + } + + assertthat::assert_that("character" %in% class(fun), + msg = "Please provide the function as a character vector." + ) + + out <- do.call( + getfun(fun), + c( + list( + data = data, + formula = as.formula(formula.glue) + ), + args.list + ) + ) + + # out <- REDCapCAST::set_attr(out,label = fun,attr = "fun.call") + + # Recreating the call + # out$call <- match.call(definition=eval(parse(text=fun)), call(fun, data = 'data',formula = as.formula(formula.str),args.list)) + + return(out) +} + +#' Create a regression model programatically +#' +#' @param data data set +#' @param fun Name of function as character vector or function to use for model creation. +#' @param vars character vector of variables to include +#' @param outcome.str Name of outcome variable. Character vector. +#' @param args.list List of arguments passed to 'fun' with 'do.call'. +#' @param ... ignored for now +#' +#' @importFrom stats as.formula +#' @rdname regression_model +#' +#' @return object of standard class for fun +#' @export +#' +#' @examples +#' \dontrun{ +#' gtsummary::trial |> +#' regression_model_uv(outcome.str = "age") +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "age", +#' fun = "stats::lm", +#' args.list = NULL +#' ) +#' m <- gtsummary::trial |> regression_model_uv( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) +#' lapply(m, broom::tidy) |> dplyr::bind_rows() +#' } +regression_model_uv <- function(data, + outcome.str, + args.list = NULL, + fun = NULL, + vars = NULL, + ...) { + ## This will handle if outcome is not in data for nicer shiny behavior + if (!outcome.str %in% names(data)) { + outcome.str <- names(data)[1] + print("outcome is not in data, first column is used") + } + + if (!is.null(vars)) { + data <- data |> + dplyr::select(dplyr::all_of( + unique(c(outcome.str, vars)) + )) + } + + if (is.null(args.list)) { + args.list <- list() + } + + if (is.null(fun)) { + if (is.numeric(data[[outcome.str]])) { + fun <- "stats::lm" + } else if (is.factor(data[[outcome.str]])) { + if (length(levels(data[[outcome.str]])) == 2) { + fun <- "stats::glm" + args.list <- list(family = stats::binomial(link = "logit")) + } else if (length(levels(data[[outcome.str]])) > 2) { + fun <- "MASS::polr" + args.list <- list( + Hess = TRUE, + method = "logistic" + ) + } else { + stop("The provided output variable only has one level") + } + } else { + stop("Output variable should be either numeric or factor for auto.mode") + } + } + + assertthat::assert_that("character" %in% class(fun), + msg = "Please provide the function as a character vector." + ) + + out <- names(data)[!names(data) %in% outcome.str] |> + purrr::map(\(.var){ + do.call( + regression_model, + c( + list( + data = data[match(c(outcome.str, .var), names(data))], + outcome.str = outcome.str + ), + args.list + ) + ) + }) + + return(out) +} + + +### HELPERS + +#' Data type assessment. +#' +#' @description +#' These are more overall than the native typeof. This is used to assess a more +#' meaningful "clinical" data type. +#' +#' @param data vector or data.frame. if data frame, each column is evaluated. +#' +#' @returns outcome type +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' lapply(data_type) +#' mtcars |> +#' default_parsing() |> +#' data_type() +#' c(1, 2) |> data_type() +#' 1 |> data_type() +#' c(rep(NA, 10)) |> data_type() +#' sample(1:100, 50) |> data_type() +#' factor(letters[1:20]) |> data_type() +#' as.Date(1:20) |> data_type() +data_type <- function(data) { + if (is.data.frame(data)) { + sapply(data, data_type) + } else { + cl_d <- class(data) + l_unique <- length(unique(na.omit(data))) + if (all(is.na(data))) { + out <- "empty" + } else if (l_unique < 2) { + out <- "monotone" + } else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) { + if (identical("logical", cl_d) | l_unique == 2) { + out <- "dichotomous" + } else { + # if (is.ordered(data)) { + # out <- "ordinal" + # } else { + out <- "categorical" + # } + } + } else if (identical(cl_d, "character")) { + out <- "text" + } else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) { + out <- "datetime" + } else if (l_unique > 2) { + ## Previously had all thinkable classes + ## Now just assumes the class has not been defined above + ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & + out <- "continuous" + } else { + out <- "unknown" + } + + out + } +} + +#' Recognised data types from data_type +#' +#' @returns vector +#' @export +#' +#' @examples +#' data_types() +data_types <- function() { + list( + "empty" = list(descr="Variable of all NAs",classes="Any class"), + "monotone" = list(descr="Variable with only one unique value",classes="Any class"), + "dichotomous" = list(descr="Variable with only two unique values",classes="Any class"), + "categorical"= list(descr="Factor variable",classes="factor (ordered or unordered)"), + "text"= list(descr="Character variable",classes="character"), + "datetime"= list(descr="Variable of time, date or datetime values",classes="hms, Date, POSIXct and POSIXt"), + "continuous"= list(descr="Numeric variable",classes="numeric, integer or double"), + "unknown"= list(descr="Anything not falling within the previous",classes="Any other class") + ) +} + + +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' supported_functions() +supported_functions <- function() { + list( + lm = list( + descr = "Linear regression model", + design = "cross-sectional", + out.type = "continuous", + fun = "stats::lm", + args.list = NULL, + formula.str = "{outcome.str}~{paste(vars,collapse='+')}", + table.fun = "gtsummary::tbl_regression", + table.args.list = list(exponentiate = FALSE) + ), + glm = list( + descr = "Logistic regression model", + design = "cross-sectional", + out.type = "dichotomous", + fun = "stats::glm", + args.list = list(family = "binomial"), + formula.str = "{outcome.str}~{paste(vars,collapse='+')}", + table.fun = "gtsummary::tbl_regression", + table.args.list = list() + ), + polr = list( + descr = "Ordinal logistic regression model", + design = "cross-sectional", + out.type = c("categorical"), + fun = "MASS::polr", + args.list = list( + Hess = TRUE, + method = "logistic" + ), + formula.str = "{outcome.str}~{paste(vars,collapse='+')}", + table.fun = "gtsummary::tbl_regression", + table.args.list = list() + ) + ) +} + + +#' Get possible regression models +#' +#' @param data data +#' +#' @returns character vector +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull("cyl") |> +#' possible_functions(design = "cross-sectional") +#' +#' mtcars |> +#' default_parsing() |> +#' dplyr::select("cyl") |> +#' possible_functions(design = "cross-sectional") +possible_functions <- function(data, design = c("cross-sectional")) { + # + # data <- if (is.reactive(data)) data() else data + if (is.data.frame(data)) { + data <- data[[1]] + } + + design <- match.arg(design) + type <- data_type(data) + + design_ls <- supported_functions() |> + lapply(\(.x){ + if (design %in% .x$design) { + .x + } + }) + + if (type == "unknown") { + out <- type + } else { + out <- design_ls |> + lapply(\(.x){ + if (type %in% .x$out.type) { + .x$descr + } + }) |> + unlist() + } + unname(out) +} + + +#' Get the function options based on the selected function description +#' +#' @param data vector +#' +#' @returns list +#' @export +#' +#' @examples +#' mtcars |> +#' default_parsing() |> +#' dplyr::pull(mpg) |> +#' possible_functions(design = "cross-sectional") |> +#' (\(.x){ +#' .x[[1]] +#' })() |> +#' get_fun_options() +get_fun_options <- function(data) { + descrs <- supported_functions() |> + lapply(\(.x){ + .x$descr + }) |> + unlist() + supported_functions() |> + (\(.x){ + .x[match(data, descrs)] + })() +} + + +#' Wrapper to create regression model based on supported models +#' +#' @description +#' Output is a concatenated list of model information and model +#' +#' +#' @param data data +#' @param outcome.str name of outcome variable +#' @param fun.descr Description of chosen function matching description in +#' "supported_functions()" +#' @param fun name of custom function. Default is NULL. +#' @param formula.str custom formula glue string. Default is NULL. +#' @param args.list custom character string to be converted using +#' argsstring2list() or list of arguments. Default is NULL. +#' @param ... ignored +#' +#' @returns list +#' @export +#' @rdname regression_model +#' +#' @examples +#' \dontrun{ +#' gtsummary::trial |> +#' regression_model( +#' outcome.str = "age", +#' fun = "stats::lm", +#' formula.str = "{outcome.str}~.", +#' args.list = NULL +#' ) +#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model") +#' summary(ls$model) +#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") +#' +#' ls <- regression_model_list(data = default_parsing(gtsummary::trial), outcome.str = "trt", fun.descr = "Logistic regression model") +#' tbl <- gtsummary::tbl_regression(ls$model, exponentiate = TRUE) +#' m <- gtsummary::trial |> +#' default_parsing() |> +#' regression_model( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' formula.str = "{outcome.str}~.", +#' args.list = list(family = "binomial") +#' ) +#' tbl2 <- gtsummary::tbl_regression(m, exponentiate = TRUE) +#' broom::tidy(ls$model) +#' broom::tidy(m) +#' } +regression_model_list <- function(data, + outcome.str, + fun.descr, + fun = NULL, + formula.str = NULL, + args.list = NULL, + vars = NULL, + ...) { + options <- get_fun_options(fun.descr) |> + (\(.x){ + .x[[1]] + })() + + ## Custom, specific fun, args and formula options + + if (is.null(formula.str)) { + formula.str.c <- options$formula.str + } else { + formula.str.c <- formula.str + } + + if (is.null(fun)) { + fun.c <- options$fun + } else { + fun.c <- fun + } + + if (is.null(args.list)) { + args.list.c <- options$args.list + } else { + args.list.c <- args.list + } + + if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c) + + ## Handling vars to print code + + if (is.null(vars)) { + vars <- names(data)[!names(data) %in% outcome.str] + } else { + if (outcome.str %in% vars) { + vars <- vars[!vars %in% outcome.str] + } + } + + parameters <- list( + data = data, + fun = fun.c, + formula.str = glue::glue(formula.str.c), + args.list = args.list.c + ) + + model <- do.call( + regression_model, + parameters + ) + + parameters_code <- Filter( + length, + modifyList(parameters, list( + data = as.symbol("df"), + formula.str = as.character(glue::glue(formula.str.c)), + outcome.str = NULL + # args.list = NULL, + )) + ) + + ## The easiest solution was to simple paste as a string + ## The rlang::call2 or rlang::expr functions would probably work as well + # code <- glue::glue("FreesearchR::regression_model({parameters_print}, args.list=list({list2str(args.list.c)}))", .null = "NULL") + code <- rlang::call2("regression_model", !!!parameters_code, .ns = "FreesearchR") + + list( + options = options, + model = model, + code = expression_string(code) + ) +} + +list2str <- function(data) { + out <- purrr::imap(data, \(.x, .i){ + if (is.logical(.x)) { + arg <- .x + } else { + arg <- glue::glue("'{.x}'") + } + glue::glue("{.i} = {arg}") + }) |> + unlist() |> + paste(collapse = (", ")) + + if (out == "") { + return(NULL) + } else { + out + } +} + + +#' @returns list +#' @export +#' @rdname regression_model +#' +#' @examples +#' \dontrun{ +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) |> +#' lapply(broom::tidy) |> +#' dplyr::bind_rows() +#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") +#' ms$code +#' ls <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "am", fun.descr = "Logistic regression model") +#' ls$code +#' lapply(ms$model, broom::tidy) |> dplyr::bind_rows() +#' } +regression_model_uv_list <- function(data, + outcome.str, + fun.descr, + fun = NULL, + formula.str = NULL, + args.list = NULL, + vars = NULL, + ...) { + options <- get_fun_options(fun.descr) |> + (\(.x){ + .x[[1]] + })() + + ## Custom, specific fun, args and formula options + + if (is.null(formula.str)) { + formula.str.c <- options$formula.str + } else { + formula.str.c <- formula.str + } + + if (is.null(fun)) { + fun.c <- options$fun + } else { + fun.c <- fun + } + + if (is.null(args.list)) { + args.list.c <- options$args.list + } else { + args.list.c <- args.list + } + + if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c) + + ## Handling vars to print code + + if (is.null(vars)) { + vars <- names(data)[!names(data) %in% outcome.str] + } else { + if (outcome.str %in% vars) { + vars <- vars[!vars %in% outcome.str] + } + } + + # assertthat::assert_that("character" %in% class(fun), + # msg = "Please provide the function as a character vector." + # ) + + # model <- do.call( + # regression_model, + # c( + # list(data = data), + # list(outcome.str = outcome.str), + # list(fun = fun.c), + # list(formula.str = formula.str.c), + # args.list.c + # ) + # ) + + model <- vars |> + lapply(\(.var){ + parameters <- + list( + fun = fun.c, + data = data[c(outcome.str, .var)], + formula.str = as.character(glue::glue(gsub("vars", ".var", formula.str.c))), + args.list = args.list.c + ) + + out <- do.call( + regression_model, + parameters + ) + + ## This is the very long version + ## Handles deeply nested glue string + # code <- glue::glue("FreesearchR::regression_model(data=df,{list2str(modifyList(parameters,list(data=NULL,args.list=list2str(args.list.c))))})") + code <- rlang::call2("regression_model", !!!modifyList(parameters, list(data = as.symbol("df"), args.list = args.list.c)), .ns = "FreesearchR") + REDCapCAST::set_attr(out, code, "code") + }) + + code <- model |> + lapply(\(.x)REDCapCAST::get_attr(.x, "code")) |> + lapply(expression_string) |> + pipe_string(collapse = ",\n") |> + (\(.x){ + paste0("list(\n", .x, ")") + })() + + + list( + options = options, + model = model, + code = code + ) +} + + +# regression_model(mtcars, fun = "stats::lm", formula.str = "mpg~cyl") + + +######## +#### Current file: /Users/au301842/FreesearchR/R//regression_plot.R +######## + +#' Regression coef plot from gtsummary. Slightly modified to pass on arguments +#' +#' @param x (`tbl_regression`, `tbl_uvregression`)\cr +#' A 'tbl_regression' or 'tbl_uvregression' object +#' @param plot_ref (scalar `logical`)\cr +#' plot reference values +#' @param remove_header_rows (scalar `logical`)\cr +#' logical indicating whether to remove header rows +#' for categorical variables. Default is `TRUE` +#' @param remove_reference_rows (scalar `logical`)\cr +#' logical indicating whether to remove reference rows +#' for categorical variables. Default is `FALSE`. +#' @param ... arguments passed to `ggstats::ggcoef_plot(...)` +#' +#' @returns ggplot object +#' @export +#' +#' @examples +#' \dontrun{ +#' mod <- lm(mpg ~ ., default_parsing(mtcars)) +#' p <- mod |> +#' gtsummary::tbl_regression() |> +#' plot(colour = "variable") +#' } +#' +plot.tbl_regression <- function(x, + plot_ref = TRUE, + remove_header_rows = TRUE, + remove_reference_rows = FALSE, + ...) { + # check_dots_empty() + gtsummary:::check_pkg_installed("ggstats") + gtsummary:::check_not_missing(x) + # gtsummary:::check_scalar_logical(remove_header_rows) + # gtsummary:::check_scalar_logical(remove_reference_rows) + + df_coefs <- x$table_body + + if (isTRUE(remove_header_rows)) { + df_coefs <- df_coefs |> dplyr::filter(!header_row %in% TRUE) + } + if (isTRUE(remove_reference_rows)) { + df_coefs <- df_coefs |> dplyr::filter(!reference_row %in% TRUE) + } + + # Removes redundant label + df_coefs$label[df_coefs$row_type == "label"] <- "" + # browser() + # Add estimate value to reference level + if (plot_ref == TRUE) { + df_coefs[df_coefs$var_type %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0 + } + + p <- df_coefs |> + ggstats::ggcoef_plot(exponentiate = x$inputs$exponentiate, ...) + + if (x$inputs$exponentiate) { + p <- symmetrical_scale_x_log10(p) + } + p +} + + +#' Wrapper to pivot gtsummary table data to long for plotting +#' +#' @param list a custom regression models list +#' @param model.names names of models to include +#' +#' @returns list +#' @export +#' +merge_long <- function(list, model.names) { + l_subset <- list$tables[model.names] + + l_merged <- l_subset |> tbl_merge() + + df_body <- l_merged$table_body + + sel_list <- lapply(seq_along(l_subset), \(.i){ + endsWith(names(df_body), paste0("_", .i)) + }) |> + setNames(names(l_subset)) + + common <- !Reduce(`|`, sel_list) + + df_body_long <- sel_list |> + purrr::imap(\(.l, .i){ + d <- dplyr::bind_cols( + df_body[common], + df_body[.l], + model = .i + ) + setNames(d, gsub("_[0-9]{,}$", "", names(d))) + }) |> + dplyr::bind_rows() |> + dplyr::mutate(model = REDCapCAST::as_factor(model)) + + l_merged$table_body <- df_body_long + + l_merged$inputs$exponentiate <- !identical(class(list$models$Multivariable$model), "lm") + + l_merged +} + + +#' Easily round log scale limits for nice plots +#' +#' @param data data +#' @param fun rounding function (floor/ceiling) +#' @param ... ignored +#' +#' @returns numeric vector +#' @export +#' +#' @examples +#' limit_log(-.1, floor) +#' limit_log(.1, ceiling) +#' limit_log(-2.1, ceiling) +#' limit_log(2.1, ceiling) +limit_log <- function(data, fun, ...) { + fun(10^-floor(data) * 10^data) / 10^-floor(data) +} + +#' Create summetric log ticks +#' +#' @param data numeric vector +#' +#' @returns numeric vector +#' @export +#' +#' @examples +#' c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics() +create_log_tics <- function(data) { + sort(round(unique(c(1 / data, data, 1)), 2)) +} + +#' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots +#' +#' @param plot ggplot2 plot +#' @param breaks breaks used and mirrored +#' @param ... ignored +#' +#' @returns ggplot2 object +#' @export +#' +symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) { + rx <- ggplot2::layer_scales(plot)$x$get_limits() + + x_min <- floor(10 * rx[1]) / 10 + x_max <- ceiling(10 * rx[2]) / 10 + + rx_min <- limit_log(rx[1], floor) + rx_max <- limit_log(rx[2], ceiling) + + max_abs_x <- max(abs(c(x_min, x_max))) + + ticks <- log10(breaks) + (ceiling(max_abs_x) - 1) + + plot + ggplot2::scale_x_log10(limits = c(rx_min, rx_max), breaks = create_log_tics(10^ticks[ticks <= max_abs_x])) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//regression_table.R +######## + +#' Create table of regression model +#' +#' @param x regression model +#' @param args.list list of arguments passed to 'fun'. +#' @param fun function to use for table creation. Default is "gtsummary::tbl_regression". +#' @param ... passed to methods +#' +#' @return object of standard class for fun +#' @export +#' @name regression_table +#' +#' @examples +#' \dontrun{ +#' tbl <- gtsummary::trial |> +#' regression_model( +#' outcome.str = "stage", +#' fun = "MASS::polr" +#' ) |> +#' regression_table(args.list = list("exponentiate" = TRUE)) +#' gtsummary::trial |> +#' regression_model( +#' outcome.str = "age", +#' fun = "stats::lm", +#' formula.str = "{outcome.str}~.", +#' args.list = NULL +#' ) |> +#' regression_table() |> +#' plot() +#' gtsummary::trial |> +#' regression_model( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = binomial(link = "logit")) +#' ) |> +#' regression_table() +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "trt", +#' fun = "stats::glm", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) |> +#' regression_table() +#' gtsummary::trial |> +#' regression_model_uv( +#' outcome.str = "stage", +#' args.list = list(family = stats::binomial(link = "logit")) +#' ) |> +#' regression_table() +#' mtcars|> +#' regression_model( +#' outcome.str = "mpg", +#' args.list = NULL) +#' ) |> +#' regression_table() +#' +#' +#' list( +#' "Univariable" = regression_model_uv, +#' "Multivariable" = regression_model +#' ) |> +#' lapply(\(.fun){ +#' do.call( +#' .fun, +#' c( +#' list(data = gtsummary::trial), +#' list(outcome.str = "stage") +#' ) +#' ) +#' }) |> +#' purrr::map(regression_table) |> +#' tbl_merge() +#' } +#' regression_table <- function(x, ...) { +#' UseMethod("regression_table") +#' } +#' +#' #' @rdname regression_table +#' #' @export +#' regression_table.list <- function(x, ...) { +#' x |> +#' purrr::map(\(.m){ +#' regression_table(x = .m, ...) |> +#' gtsummary::add_n() +#' }) |> +#' gtsummary::tbl_stack() +#' } +#' +#' #' @rdname regression_table +#' #' @export +#' regression_table.default <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") { +#' # Stripping custom class +#' class(x) <- class(x)[class(x) != "freesearchr_model"] +#' +#' if (any(c(length(class(x)) != 1, class(x) != "lm"))) { +#' if (!"exponentiate" %in% names(args.list)) { +#' args.list <- c(args.list, list(exponentiate = TRUE)) +#' } +#' } +#' +#' out <- do.call(getfun(fun), c(list(x = x), args.list)) +#' out |> +#' gtsummary::add_glance_source_note() # |> +#' # gtsummary::bold_p() +#' } +regression_table <- function(x, ...) { + args <- list(...) + + if ("list" %in% class(x)) { + x |> + purrr::map(\(.m){ + regression_table_create(x = .m, args.list = args) |> + gtsummary::add_n() + }) |> + gtsummary::tbl_stack() + } else { + regression_table_create(x, args.list = args) + } +} + +#' Create regression summary table +#' +#' @param x (list of) regression model +#' @param ... ignored for now +#' @param args.list args.list for the summary function +#' @param fun table summary function. Default is "gtsummary::tbl_regression" +#' @param theme summary table theme +#' +#' @returns gtsummary list object +#' @export +#' +regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression", theme = c("jama", "lancet", "nejm", "qjecon")) { + # Stripping custom class + class(x) <- class(x)[class(x) != "freesearchr_model"] + + theme <- match.arg(theme) + + if (any(c(length(class(x)) != 1, class(x) != "lm"))) { + if (!"exponentiate" %in% names(args.list)) { + args.list <- c(args.list, list(exponentiate = TRUE, p.values = TRUE)) + } + } + + gtsummary::theme_gtsummary_journal(journal = theme) + if (inherits(x, "polr")) { + # browser() + out <- do.call(getfun(fun), c(list(x = x), args.list)) + # out <- do.call(getfun(fun), c(list(x = x, tidy_fun = list(residual_type = "normal")), args.list)) + # out <- do.call(what = getfun(fun), + # args = c( + # list( + # x = x, + # tidy_fun = list( + # conf.int = TRUE, + # conf.level = 0.95, + # residual_type = "normal")), + # args.list) + # ) + } else { + out <- do.call(getfun(fun), c(list(x = x), args.list)) + } + + out +} + + +#' A substitue to gtsummary::tbl_merge, that will use list names for the tab +#' spanner names. +#' +#' @param data gtsummary list object +#' +#' @return gt summary list object +#' @export +#' +tbl_merge <- function(data) { + if (is.null(names(data))) { + data |> gtsummary::tbl_merge() + } else { + data |> gtsummary::tbl_merge(tab_spanner = names(data)) + } +} + +# as_kable(tbl) |> write_lines(file=here::here("inst/apps/data_analysis_modules/www/_table1.md")) +# as_kable_extra(tbl)|> write_lines(file=here::here("inst/apps/data_analysis_modules/www/table1.md")) + + +######## +#### Current file: /Users/au301842/FreesearchR/R//regression-module.R +######## + +### On rewriting this module +### +### This module (and the plotting module) should be rewritten to allow for +### dynamically defining variable-selection for model evaluation. +### The principle of having a library of supported functions is fine, but should +### be expanded. +### +### + +# list( +# lm = list( +# descr = "Linear regression model", +# design = "cross-sectional", +# parameters=list( +# fun = "stats::lm", +# args.list = NULL +# ), +# variables = list( +# outcome.str = list( +# fun = "columnSelectInput", +# multiple = FALSE, +# label = "Select the dependent/outcome variable." +# ) +# ), +# out.type = "continuous", +# formula.str = "{outcome.str}~{paste(vars,collapse='+')}", +# table.fun = "gtsummary::tbl_regression", +# table.args.list = list(exponentiate = FALSE) +# )) +# +# Regarding the regression model, it really should be the design selection, +# that holds the input selection information, as this is what is deciding +# the number and type of primary inputs. +# +# Cross-sectional: outcome +# MMRM: outcome, random effect (id, time) +# Survival: time, status, strata(?) +# +# + + + +regression_ui <- function(id, ...) { + ns <- shiny::NS(id) + + shiny::tagList( + title = "", + sidebar = bslib::sidebar( + shiny::uiOutput(outputId = ns("data_info"), inline = TRUE), + bslib::accordion( + open = "acc_reg", + multiple = FALSE, + bslib::accordion_panel( + value = "acc_reg", + title = "Regression", + icon = bsicons::bs_icon("calculator"), + shiny::uiOutput(outputId = ns("outcome_var")), + # shiny::selectInput( + # inputId = "design", + # label = "Study design", + # selected = "no", + # inline = TRUE, + # choices = list( + # "Cross-sectional" = "cross-sectional" + # ) + # ), + shiny::uiOutput(outputId = ns("regression_type")), + shiny::radioButtons( + inputId = ns("all"), + label = "Specify covariables", + inline = TRUE, selected = 2, + choiceNames = c( + "Yes", + "No" + ), + choiceValues = c(1, 2) + ), + shiny::conditionalPanel( + condition = "input.all==1", + shiny::uiOutput(outputId = ns("regression_vars")), + shiny::helpText("If none are selected, all are included."), + shiny::tags$br(), + ns = ns + ), + bslib::input_task_button( + id = ns("load"), + label = "Analyse", + icon = bsicons::bs_icon("pencil"), + label_busy = "Working...", + icon_busy = fontawesome::fa_i("arrows-rotate", + class = "fa-spin", + "aria-hidden" = "true" + ), + type = "secondary", + auto_reset = TRUE + ), + shiny::helpText("Press 'Analyse' to create the regression model and after changing parameters."), + shiny::tags$br(), + shiny::radioButtons( + inputId = ns("add_regression_p"), + label = "Show p-value", + inline = TRUE, + selected = "yes", + choices = list( + "Yes" = "yes", + "No" = "no" + ) + ), + # shiny::tags$br(), + # shiny::radioButtons( + # inputId = ns("tbl_theme"), + # label = "Show p-value", + # inline = TRUE, + # selected = "jama", + # choices = list( + # "JAMA" = "jama", + # "Lancet" = "lancet", + # "NEJM" = "nejm" + # ) + # ), + shiny::tags$br() + ), + do.call( + bslib::accordion_panel, + c( + list( + value = "acc_plot", + title = "Coefficient plot", + icon = bsicons::bs_icon("bar-chart-steps"), + shiny::tags$br(), + shiny::uiOutput(outputId = ns("plot_model")) + ), + # plot_download_ui(ns("reg_plot_download")) + shiny::tagList( + shinyWidgets::noUiSliderInput( + inputId = ns("plot_height"), + label = "Plot height (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shinyWidgets::noUiSliderInput( + inputId = ns("plot_width"), + label = "Plot width (mm)", + min = 50, + max = 300, + value = 100, + step = 1, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shiny::selectInput( + inputId = ns("plot_type"), + label = "File format", + choices = list( + "png", + "tiff", + "eps", + "pdf", + "jpeg", + "svg" + ) + ), + shiny::br(), + # Button + shiny::downloadButton( + outputId = ns("download_plot"), + label = "Download plot", + icon = shiny::icon("download") + ) + ) + ) + ), + bslib::accordion_panel( + value = "acc_checks", + title = "Checks", + icon = bsicons::bs_icon("clipboard-check"), + shiny::uiOutput(outputId = ns("plot_checks")) + ) + ) + ), + bslib::nav_panel( + title = "Regression table", + gt::gt_output(outputId = ns("table2")) + ), + bslib::nav_panel( + title = "Coefficient plot", + shiny::plotOutput(outputId = ns("regression_plot"), height = "80vh") + ), + bslib::nav_panel( + title = "Model checks", + shiny::plotOutput(outputId = ns("check"), height = "90vh") + ) + ) +} + + +regression_server <- function(id, + data, + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + ns <- session$ns + + rv <- shiny::reactiveValues( + data = NULL, + plot = NULL, + check = NULL, + list = list() + ) + + data_r <- shiny::reactive({ + if (shiny::is.reactive(data)) { + data() + } else { + data + } + }) + + output$data_info <- shiny::renderUI({ + shiny::req(regression_vars()) + shiny::req(data_r()) + data_description(data_r()[regression_vars()]) + }) + + ############################################################################## + ######### + ######### Input fields + ######### + ############################################################################## + + ## Keep these "old" selection options as a simple alternative to the modification pane + + + output$regression_vars <- shiny::renderUI({ + columnSelectInput( + inputId = ns("regression_vars"), + selected = NULL, + label = "Covariables to include", + data = data_r(), + multiple = TRUE + ) + }) + + output$outcome_var <- shiny::renderUI({ + columnSelectInput( + inputId = ns("outcome_var"), + selected = NULL, + label = "Select outcome variable", + data = data_r(), + multiple = FALSE + ) + }) + + output$regression_type <- shiny::renderUI({ + shiny::req(input$outcome_var) + shiny::selectizeInput( + inputId = ns("regression_type"), + label = "Choose regression analysis", + ## The below ifelse statement handles the case of loading a new dataset + choices = possible_functions( + data = dplyr::select( + data_r(), + ifelse(input$outcome_var %in% names(data_r()), + input$outcome_var, + names(data_r())[1] + ) + ), design = "cross-sectional" + ), + multiple = FALSE + ) + }) + + output$factor_vars <- shiny::renderUI({ + shiny::selectizeInput( + inputId = ns("factor_vars"), + selected = colnames(data_r())[sapply(data_r(), is.factor)], + label = "Covariables to format as categorical", + choices = colnames(data_r()), + multiple = TRUE + ) + }) + + ## Collected regression variables + regression_vars <- shiny::reactive({ + if (is.null(input$regression_vars)) { + out <- colnames(data_r()) + } else { + out <- unique(c(input$regression_vars, input$outcome_var)) + } + return(out) + }) + + output$strat_var <- shiny::renderUI({ + columnSelectInput( + inputId = ns("strat_var"), + selected = "none", + label = "Select variable to stratify baseline", + data = data_r(), + col_subset = c( + "none", + names(data_r())[unlist(lapply(data_r(), data_type)) %in% c("dichotomous", "categorical", "ordinal")] + ) + ) + }) + + + output$plot_model <- shiny::renderUI({ + shiny::req(rv$list$regression$tables) + shiny::selectInput( + inputId = ns("plot_model"), + selected = 1, + label = "Select models to plot", + choices = names(rv$list$regression$tables), + multiple = TRUE + ) + }) + + ############################################################################## + ######### + ######### Regression models + ######### + ############################################################################## + + shiny::observeEvent( + input$load, + { + shiny::req(input$outcome_var) + + rv$list$regression$models <- NULL + + tryCatch( + { + ## Which models to create should be decided by input + ## Could also include + ## imputed or + ## minimally adjusted + model_lists <- list( + "Univariable" = "regression_model_uv_list", + "Multivariable" = "regression_model_list" + ) |> + lapply(\(.fun){ + parameters <- list( + data = data_r()[regression_vars()], + outcome.str = input$outcome_var, + fun.descr = input$regression_type + ) + + do.call( + .fun, + parameters + ) + }) + + rv$list$regression$params <- get_fun_options(input$regression_type) |> + (\(.x){ + .x[[1]] + })() + + rv$list$regression$models <- model_lists + }, + error = function(err) { + showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err") + } + ) + } + ) + + + + shiny::observeEvent( + list( + data_r(), + regression_vars() + ), + { + rv$list$regression$tables <- NULL + } + ) + + ############################################################################## + ######### + ######### Regression table + ######### + ############################################################################## + + ### Creating the regression table + shiny::observeEvent( + input$load, + { + shiny::req(rv$list$regression$models) + ## To avoid plotting old models on fail/error + rv$list$regression$tables <- NULL + + # browser() + tryCatch( + { + parameters <- list( + p.values = input$add_regression_p == "no" + ) + + out <- lapply(rv$list$regression$models, \(.x){ + .x$model + }) |> + purrr::map(\(.x){ + do.call( + regression_table, + append_list(.x, parameters, "x") + ) + }) + + rv$list$regression$models |> + purrr::imap(\(.x, .i){ + rv$list$regression$models[[.i]][["code_table"]] <- paste( + .x$code, + expression_string(rlang::call2(.fn = "regression_table", !!!parameters, .ns = "FreesearchR"), assign.str = NULL), + sep = "|>\n" + ) + }) + + rv$list$regression$tables <- out + rv$list$input <- input + }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, + error = function(err) { + showNotification(paste0("Creating a regression table failed with the following error: ", err), type = "err") + } + ) + } + ) + + ## Consider creating merged table with theming and then passing object + ## to render. + + output$table2 <- gt::render_gt({ + ## Print checks if a regression table is present + if (!is.null(rv$list$regression$tables)) { + # gtsummary::theme_gtsummary_journal(journal = "jama") + merged <- rv$list$regression$tables |> + tbl_merge() + + if (input$add_regression_p == "no") { + merged <- merged |> + gtsummary::modify_column_hide(column = dplyr::starts_with("p.value")) + } + + out <- merged |> + gtsummary::as_gt() |> + gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) + + # rv$list$regression$table_merged <- out + + out + } else { + return(NULL) + } + }) + + ############################################################################## + ######### + ######### Coefficients plot + ######### + ############################################################################## + + shiny::observeEvent(list( + input$plot_model, + rv$list$regression + ), { + shiny::req(input$plot_model) + + tryCatch( + { + p <- merge_long( + rv$list$regression, + sort_by( + input$plot_model, + c("Univariable", "Minimal", "Multivariable"), + na.rm = TRUE + ) + ) |> + (\(.x){ + if (length(input$plot_model) > 1) { + plot.tbl_regression( + x = .x, + colour = "model", + dodged = TRUE + ) + + ggplot2::theme(legend.position = "bottom") + + ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE)) + } else { + plot.tbl_regression( + x = .x, + colour = "variable" + ) + + ggplot2::theme(legend.position = "none") + } + })() + + rv$plot <- p + + ggplot2::scale_y_discrete(labels = scales::label_wrap(15)) + + gg_theme_shiny() + }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) + }) + + + output$regression_plot <- shiny::renderPlot( + { + shiny::req(input$plot_model) + + rv$plot + }, + alt = "Regression coefficient plot" + ) + + # plot_download_server( + # id = ns("reg_plot_download"), + # data = shiny::reactive(rv$plot) + # ) + + output$download_plot <- shiny::downloadHandler( + filename = paste0("regression_plot.", input$plot_type), + content = function(file) { + shiny::withProgress(message = "Saving the plot. Hold on for a moment..", { + ggplot2::ggsave( + filename = file, + plot = rv$plot, + width = input$plot_width, + height = input$plot_height, + dpi = 300, + units = "mm", scale = 2 + ) + }) + } + ) + + ############################################################################## + ######### + ######### Model checks + ######### + ############################################################################## + + shiny::observeEvent( + list( + rv$list$regression$models + ), + { + shiny::req(rv$list$regression$models) + tryCatch( + { + rv$check <- lapply(rv$list$regression$models, \(.x){ + .x$model + }) |> + purrr::pluck("Multivariable") |> + performance::check_model() + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err") + } + ) + } + ) + + rv$check_plot <- shiny::reactive(plot(rv$check)) + + output$plot_checks <- shiny::renderUI({ + shiny::req(rv$list$regression$models) + shiny::req(rv$check_plot) + + ## Implement correct plotting + names <- sapply(rv$check_plot(), \(.i){ + # .i$labels$title + get_ggplot_label(.i, "title") + }) + + vectorSelectInput( + inputId = ns("plot_checks"), + selected = 1, + label = "Select checks to plot", + choices = names, + multiple = TRUE + ) + }) + + output$check <- shiny::renderPlot( + { + shiny::req(rv$check_plot) + shiny::req(input$plot_checks) + + ## Print checks if a regression table is present + if (!is.null(rv$list$regression$tables)) { + p <- rv$check_plot() + + # patchwork::wrap_plots() + + patchwork::plot_annotation(title = "Multivariable regression model checks") + + + layout <- sapply(seq_len(length(p)), \(.x){ + patchwork::area(.x, 1) + }) + + p_list <- p + patchwork::plot_layout(design = Reduce(c, layout)) + + index <- match( + input$plot_checks, + sapply(rv$check_plot(), \(.i){ + get_ggplot_label(.i, "title") + }) + ) + + ls <- list() + + for (i in index) { + p <- p_list[[i]] + + ggplot2::theme( + axis.text = ggplot2::element_text(size = 10), + axis.title = ggplot2::element_text(size = 12), + legend.text = ggplot2::element_text(size = 12), + plot.subtitle = ggplot2::element_text(size = 12), + plot.title = ggplot2::element_text(size = 18) + ) + ls <- c(ls, list(p)) + } + # browser() + tryCatch( + { + out <- patchwork::wrap_plots(ls, ncol = if (length(ls) == 1) 1 else 2) + }, + error = function(err) { + showNotification(err, type = "err") + } + ) + + out + } else { + return(NULL) + } + }, + alt = "Assumptions testing of the multivariable regression model" + ) + + ############################################################################## + ######### + ######### Output + ######### + ############################################################################## + + return(shiny::reactive({ + rv$list + })) + } + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//report.R +######## + +#' Split vector by an index and embed addition +#' +#' @param data vector +#' @param index split index +#' @param add addition +#' +#' @return vector +#' @export +#' +index_embed <- function(data, index, add = NULL) { + start <- seq_len(index) + end <- seq_along(data)[-start] + c( + data[start], + add, + data[end] + ) +} + +#' Specify format arguments to include in qmd header/frontmatter +#' +#' @param data vector +#' @param fileformat format to include +#' +#' @return vector +#' @export +#' +specify_qmd_format <- function(data, fileformat = c("docx", "odt", "pdf", "all")) { + fileformat <- match.arg(fileformat) + args_list <- default_format_arguments() |> purrr::imap(format_writer) + + if (fileformat == "all") { + out <- data |> index_embed(index = 4, add = Reduce(c, args_list)) + } else { + out <- data |> index_embed(index = 4, add = args_list[[fileformat]]) + } + out +} + +#' Merges list of named arguments for qmd header generation +#' +#' @param data vector +#' @param name name +#' +#' @return vector +#' @export +#' +format_writer <- function(data, name) { + if (data == "default") { + glue::glue(" {name}: {data}") + } else { + warning("Not implemented") + } +} + +#' Defaults qmd formats +#' +#' @return list +#' @export +#' +default_format_arguments <- function() { + list( + docx = list("default"), + odt = list("default"), + pdf = list("default") + ) +} + +#' Wrapper to modify quarto file to render specific formats +#' +#' @param file filename +#' @param format desired output +#' +#' @return none +#' @export +#' +modify_qmd <- function(file, format) { + readLines(file) |> + specify_qmd_format(fileformat = "all") |> + writeLines(paste0(tools::file_path_sans_ext(file), "_format.", tools::file_ext(file))) +} + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//syntax_highlight.R +######## + +## Inpiration: +## +## https://stackoverflow.com/questions/47445260/how-to-enable-syntax-highlighting-in-r-shiny-app-with-htmloutput + +prismCodeBlock <- function(code) { + tagList( + HTML(html_code_wrap(code)), + tags$script("Prism.highlightAll()") + ) +} + +prismDependencies <- tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/prism.min.js"), + tags$link(rel = "stylesheet", type = "text/css", + href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/themes/prism.min.css") +) + +prismRDependency <- tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.8.4/components/prism-r.min.js") +) + +html_code_wrap <- function(string,lang="r"){ + glue::glue("
{string}
+
") +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//theme.R +######## + +#' Custom theme based on unity +#' +#' @param ... everything passed on to bslib::bs_theme() +#' +#' @returns theme list +#' @export +custom_theme <- function(..., + version = 5, + primary = FreesearchR_colors("primary"), + secondary = FreesearchR_colors("secondary"), + bootswatch = "united", + base_font = bslib::font_google("Montserrat"), + heading_font = bslib::font_google("Public Sans", wght = "700"), + code_font = bslib::font_google("Open Sans"), + success = FreesearchR_colors("success"), + info = FreesearchR_colors("info"), + warning = FreesearchR_colors("warning"), + danger = FreesearchR_colors("danger") + # fg = "#000", + # bg="#fff", + # base_font = bslib::font_google("Alice"), + # heading_font = bslib::font_google("Jost", wght = "800"), + # heading_font = bslib::font_google("Noto Serif"), + # heading_font = bslib::font_google("Alice"), +) { + bslib::bs_theme( + ..., + "navbar-bg" = primary, + version = version, + primary = primary, + secondary = secondary, + bootswatch = bootswatch, + base_font = base_font, + heading_font = heading_font, + code_font = code_font, + success=success, + info=info, + warning=warning, + danger=danger + ) +} + +FreesearchR_colors <- function(choose = NULL) { + out <- c( + primary = "#1E4A8F", + secondary = "#FF6F61", + success = "#00C896", + warning = "#FFB100", + danger = "#CC2E25", + extra = "#8A4FFF", + info = "#11A0EC", + bg = "#FFFFFF", + dark = "#2D2D42", + fg = "#000000" + ) + if (!is.null(choose)) { + unname(out[choose]) + } else { + out + } +} + +#' Use the FreesearchR colors +#' +#' @param n number of colors +#' +#' @returns character vector +#' @export +#' +#' @examples +#' FreesearchR_palette(n=7) +FreesearchR_palette <- function(n){ + rep_len(FreesearchR_colors(),n) +} + + + +#' GGplot default theme for plotting in Shiny +#' +#' @param data ggplot object +#' +#' @returns ggplot object +#' @export +#' +gg_theme_shiny <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text = ggplot2::element_text(size = 14), + strip.text = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24), + plot.subtitle = ggplot2::element_text(size = 18) + ) +} + + +#' GGplot default theme for plotting export objects +#' +#' @param data ggplot object +#' +#' @returns ggplot object +#' @export +#' +gg_theme_export <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text.x = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24) + ) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//update-factor-ext.R +######## + + +## Works, but not implemented +## +## These edits mainly allows for + + +#' @title Module to Reorder the Levels of a Factor Variable +#' +#' @description +#' This module contain an interface to reorder the levels of a factor variable. +#' +#' +#' @param id Module ID. +#' +#' @return A [shiny::reactive()] function returning the data. +#' @export +#' +#' @importFrom shiny NS fluidRow tagList column actionButton +#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox +#' @importFrom toastui datagridOutput +#' @importFrom htmltools tags +#' +#' @name update-factor +#' +update_factor_ui <- function(id) { + ns <- NS(id) + tagList( + tags$style( + ".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}" + ), + fluidRow( + column( + width = 6, + shinyWidgets::virtualSelectInput( + inputId = ns("variable"), + label = i18n("Factor variable to reorder:"), + choices = NULL, + width = "100%", + zIndex = 50 + ) + ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + inputId = ns("sort_levels"), + label = tagList( + phosphoricons::ph("sort-ascending"), + datamods:::i18n("Sort by levels") + ), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ), + column( + width = 3, + class = "d-flex align-items-end", + actionButton( + inputId = ns("sort_occurrences"), + label = tagList( + phosphoricons::ph("sort-ascending"), + datamods:::i18n("Sort by count") + ), + class = "btn-outline-primary mb-3", + width = "100%" + ) + ) + ), + toastui::datagridOutput(ns("grid")), + tags$div( + class = "float-end", + shinyWidgets::prettyCheckbox( + inputId = ns("new_var"), + label = datamods:::i18n("Create a new variable (otherwise replaces the one selected)"), + value = FALSE, + status = "primary", + outline = TRUE, + inline = TRUE + ), + actionButton( + inputId = ns("create"), + label = tagList(phosphoricons::ph("arrow-clockwise"), datamods:::i18n("Update factor variable")), + class = "btn-outline-primary" + ) + ), + tags$div(class = "clearfix") + ) +} + + +#' @param data_r A [shiny::reactive()] function returning a `data.frame`. +#' +#' @export +#' +#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton +#' @importFrom shinyWidgets updateVirtualSelect +#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar +#' +#' @rdname update-factor +update_factor_server <- function(id, data_r = reactive(NULL)) { + moduleServer( + id, + function(input, output, session) { + + rv <- reactiveValues(data = NULL, data_grid = NULL) + + bindEvent(observe({ + data <- data_r() + rv$data <- data + vars_factor <- vapply(data, is.factor, logical(1)) + vars_factor <- names(vars_factor)[vars_factor] + updateVirtualSelect( + inputId = "variable", + choices = vars_factor, + selected = if (isTruthy(input$variable)) input$variable else vars_factor[1] + ) + }), data_r(), input$hidden) + + observeEvent(input$variable, { + data <- req(data_r()) + variable <- req(input$variable) + grid <- as.data.frame(table(data[[variable]])) + rv$data_grid <- grid + }) + + observeEvent(input$sort_levels, { + if (input$sort_levels %% 2 == 1) { + decreasing <- FALSE + label <- tagList( + phosphoricons::ph("sort-descending"), + "Sort Levels" + ) + } else { + decreasing <- TRUE + label <- tagList( + phosphoricons::ph("sort-ascending"), + "Sort Levels" + ) + } + updateActionButton(inputId = "sort_levels", label = as.character(label)) + rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ] + }) + + observeEvent(input$sort_occurrences, { + if (input$sort_occurrences %% 2 == 1) { + decreasing <- FALSE + label <- tagList( + phosphoricons::ph("sort-descending"), + datamods:::i18n("Sort count") + ) + } else { + decreasing <- TRUE + label <- tagList( + phosphoricons::ph("sort-ascending"), + datamods:::i18n("Sort count") + ) + } + updateActionButton(inputId = "sort_occurrences", label = as.character(label)) + rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ] + }) + + + output$grid <- renderDatagrid({ + req(rv$data_grid) + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + data <- rv$data_grid + data <- add_var_toset(data, "Var1", "New label") + + grid <- datagrid( + data = data, + draggable = TRUE, + sortable = FALSE, + data_as_input = TRUE + ) + grid <- grid_columns( + grid, + columns = c("Var1", "Var1_toset", "Freq"), + header = c(datamods:::i18n("Levels"), "New label", datamods:::i18n("Count")) + ) + grid <- grid_colorbar( + grid, + column = "Freq", + label_outside = TRUE, + label_width = "30px", + background = "#D8DEE9", + bar_bg = datamods:::get_primary_color(), + from = c(0, max(rv$data_grid$Freq) + 1) + ) + grid <- toastui::grid_style_column( + grid = grid, + column = "Var1_toset", + fontStyle = "italic" + ) + grid <- toastui::grid_editor( + grid = grid, + column = "Var1_toset", + type = "text" + ) + grid + }) + + data_updated_r <- reactive({ + data <- req(data_r()) + variable <- req(input$variable) + grid <- req(input$grid_data) + name_var <- if (isTRUE(input$new_var)) { + paste0(variable, "_updated") + } else { + variable + } + data[[name_var]] <- factor( + as.character(data[[variable]]), + levels = grid[["Var1"]] + ) + data[[name_var]] <- factor( + data[[variable]], + labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]]) + ) + data + }) + + data_returned_r <- observeEvent(input$create, { + rv$data <- data_updated_r() + }) + return(reactive(rv$data)) + } + ) +} + + + +#' @inheritParams shiny::modalDialog +#' @export +#' +#' @importFrom shiny showModal modalDialog textInput +#' @importFrom htmltools tagList +#' +#' @rdname update-factor +modal_update_factor <- function(id, + title = i18n("Update levels of a factor"), + easyClose = TRUE, + size = "l", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + update_factor_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + ), + easyClose = easyClose, + size = size, + footer = footer + )) +} + + +#' @inheritParams shinyWidgets::WinBox +#' @export +#' +#' @importFrom shinyWidgets WinBox wbOptions wbControls +#' @importFrom htmltools tagList +#' @rdname update-factor +winbox_update_factor <- function(id, + title = i18n("Update levels of a factor"), + options = shinyWidgets::wbOptions(), + controls = shinyWidgets::wbControls()) { + ns <- NS(id) + WinBox( + title = title, + ui = tagList( + update_factor_ui(id), + tags$div( + style = "display: none;", + textInput(inputId = ns("hidden"), label = NULL, value = genId()) + ) + ), + options = modifyList( + shinyWidgets::wbOptions(height = "615px", modal = TRUE), + options + ), + controls = controls, + auto_height = FALSE + ) +} + + + +######## +#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R +######## + +#' Select, rename and convert variables +#' +#' @param id Module id. See [shiny::moduleServer()]. +#' @param title Module's title, if `TRUE` use the default title, +#' use \code{NULL} for no title or a `shiny.tag` for a custom one. +#' +#' @return A [shiny::reactive()] function returning the updated data. +#' @export +#' +#' @name update-variables +#' +update_variables_ui <- function(id, title = "") { + ns <- NS(id) + if (isTRUE(title)) { + title <- htmltools::tags$h4( + i18n("Update & select variables"), + class = "datamods-title" + ) + } + htmltools::tags$div( + class = "datamods-update", + shinyWidgets::html_dependency_pretty(), + title, + htmltools::tags$div( + style = "min-height: 25px;", + htmltools::tags$div( + shiny::uiOutput(outputId = ns("data_info"), inline = TRUE), + shiny::tagAppendAttributes( + shinyWidgets::dropMenu( + placement = "bottom-end", + shiny::actionButton( + inputId = ns("settings"), + label = phosphoricons::ph("gear"), + class = "pull-right float-right" + ), + shinyWidgets::textInputIcon( + inputId = ns("format"), + label = i18n("Date format:"), + value = "%Y-%m-%d", + icon = list(phosphoricons::ph("clock")) + ), + shinyWidgets::textInputIcon( + inputId = ns("origin"), + label = i18n("Date to use as origin to convert date/datetime:"), + value = "1970-01-01", + icon = list(phosphoricons::ph("calendar")) + ), + shinyWidgets::textInputIcon( + inputId = ns("dec"), + label = i18n("Decimal separator:"), + value = ".", + icon = list("0.00") + ) + ), + style = "display: inline;" + ) + ), + htmltools::tags$br(), + toastui::datagridOutput(outputId = ns("table")) + ), + htmltools::tags$br(), + htmltools::tags$div( + id = ns("update-placeholder"), + shinyWidgets::alert( + id = ns("update-result"), + status = "info", + phosphoricons::ph("info"), + paste( + "Select variables to keep (if none selected, all are kept), rename", + "variables and labels, and convert variable type/class in the table", + "above. Apply changes by clicking the button below." + ) + ) + ), + shiny::actionButton( + inputId = ns("validate"), + label = htmltools::tagList( + phosphoricons::ph("arrow-circle-right", title = datamods::i18n("Apply changes")), + datamods::i18n("Apply changes") + ), + width = "100%" + ) + ) +} + +#' @export +#' +#' @param id Module's ID +#' @param data a \code{data.frame} or a \code{reactive} function returning a \code{data.frame}. +#' @param height Height for the table. +#' @param return_data_on_init Return initial data when module is called. +#' @param try_silent logical: should the report of error messages be suppressed? +#' +#' @rdname update-variables +#' +update_variables_server <- function(id, + data, + height = NULL, + return_data_on_init = FALSE, + try_silent = FALSE) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + ns <- session$ns + updated_data <- shiny::reactiveValues(x = NULL) + + data_r <- shiny::reactive({ + if (shiny::is.reactive(data)) { + data() + } else { + data + } + }) + + output$data_info <- shiny::renderUI({ + shiny::req(data_r()) + data_description(data_r()) + # sprintf(i18n("Data has %s observations and %s variables."), nrow(data), ncol(data)) + }) + + variables_r <- shiny::reactive({ + shiny::validate( + shiny::need(data(), i18n("No data to display.")) + ) + data <- data_r() + if (isTRUE(return_data_on_init)) { + updated_data$x <- data + } else { + updated_data$x <- NULL + } + summary_vars(data) + }) + + output$table <- toastui::renderDatagrid({ + shiny::req(variables_r()) + + variables <- variables_r() + + update_variables_datagrid( + variables, + height = height, + selectionId = ns("row_selected"), + buttonId = "validate" + ) + }) + + shiny::observeEvent(input$validate, + { + updated_data$list_rename <- NULL + updated_data$list_select <- NULL + updated_data$list_mutate <- NULL + updated_data$list_relabel <- NULL + # shiny::req(updated_data$x) + data <- data_r() + new_selections <- input$row_selected + if (length(new_selections) < 1) { + new_selections <- seq_along(data) + } + + data_inputs <- data.table::as.data.table(input$table_data) + data.table::setorderv(data_inputs, "rowKey") + + old_names <- data_inputs$name + new_names <- data_inputs$name_toset + new_names[new_names == "New name"] <- NA + new_names[is.na(new_names)] <- old_names[is.na(new_names)] + new_names[new_names == ""] <- old_names[new_names == ""] + + # browser() + + old_label <- data_inputs$label + new_label <- data_inputs$label_toset + + new_label[new_label == "New label"] <- old_label[new_label == "New label"] + + ## Later, "" will be interpreted as NA/empty and removed + new_label[is.na(new_label) | new_label %in% c('""',"''"," ")] <- "" + + # new_label[is.na(new_label)] <- old_label[is.na(new_label)] + new_label <- setNames(new_label, new_names) + + new_classes <- data_inputs$class_toset + new_classes[new_classes == "Select"] <- NA + + data_sv <- variables_r() + vars_to_change <- get_vars_to_convert(data_sv, setNames(as.list(new_classes), old_names)) + + res_update <- try( + { + # convert + if (nrow(vars_to_change) > 0) { + data <- convert_to( + data = data, + variable = vars_to_change$name, + new_class = vars_to_change$class_to_set, + origin = input$origin, + format = input$format, + dec = input$dec + ) + } + list_mutate <- attr(data, "code_03_convert") + + # rename + list_rename <- setNames( + as.list(old_names), + unlist(new_names, use.names = FALSE) + ) + list_rename <- list_rename[names(list_rename) != unlist(list_rename, use.names = FALSE)] + names(data) <- unlist(new_names, use.names = FALSE) + + # relabel + list_relabel <- as.list(new_label) + data <- set_column_label(data, list_relabel) + + # select + list_select <- setdiff(names(data), names(data)[new_selections]) + data <- data[, new_selections, drop = FALSE] + }, + silent = try_silent + ) + + if (inherits(res_update, "try-error")) { + datamods:::insert_error(selector = "update") + } else { + datamods:::insert_alert( + selector = ns("update"), + status = "success", + tags$b(phosphoricons::ph("check"), datamods::i18n("Data successfully updated!")) + ) + updated_data$x <- data + updated_data$list_rename <- list_rename + updated_data$list_select <- list_select + updated_data$list_mutate <- list_mutate + updated_data$list_relabel <- list_relabel + } + }, + ignoreNULL = TRUE, + ignoreInit = TRUE + ) + + # shiny::observeEvent(input$close, + # { + return(shiny::reactive({ + shiny::req(updated_data$x) + # browser() + data <- updated_data$x + code <- list() + if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) { + code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate,.ns="dplyr"))) + } + if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) { + code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename,.ns="dplyr"))) + } + if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) { + code <- c(code, list(rlang::expr(dplyr::select(-dplyr::any_of(c(!!!updated_data$list_select)))))) + } + if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) { + code <- c(code,list(rlang::call2("set_column_label",label=updated_data$list_relabel,.ns="FreesearchR"))) + } + if (length(code) > 0) { + attr(data, "code") <- Reduce( + f = function(x, y) rlang::expr(!!x %>% !!y), + x = code + ) + } + return(data) + })) + # }) + + # shiny::reactive({ + # data <- updated_data$x + # code <- list() + # if (!is.null(data) && shiny::isTruthy(updated_data$list_mutate) && length(updated_data$list_mutate) > 0) { + # code <- c(code, list(rlang::call2("mutate", !!!updated_data$list_mutate))) + # } + # if (!is.null(data) && shiny::isTruthy(updated_data$list_rename) && length(updated_data$list_rename) > 0) { + # code <- c(code, list(rlang::call2("rename", !!!updated_data$list_rename))) + # } + # if (!is.null(data) && shiny::isTruthy(updated_data$list_select) && length(updated_data$list_select) > 0) { + # code <- c(code, list(rlang::expr(select(-any_of(c(!!!updated_data$list_select)))))) + # } + # if (!is.null(data) && shiny::isTruthy(updated_data$list_relabel) && length(updated_data$list_relabel) > 0) { + # code <- c(code, list(rlang::call2("purrr::map2(list_relabel, + # function(.data,.label){ + # REDCapCAST::set_attr(.data,.label,attr = 'label') + # }) |> dplyr::bind_cols(.name_repair = 'unique_quiet')"))) + # } + # if (length(code) > 0) { + # attr(data, "code") <- Reduce( + # f = function(x, y) rlang::expr(!!x %>% !!y), + # x = code + # ) + # } + # updated_data$return_data <- data + # }) + + # shiny::observeEvent(input$close, + # { + # shiny::req(input$close) + # return(shiny::reactive({ + # data <- updated_data$return_data + # return(data) + # })) + # }) + } + ) +} + + +modal_update_variables <- function(id, + title = "Select, rename and reclass variables", + easyClose = TRUE, + size = "xl", + footer = NULL) { + ns <- NS(id) + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + update_variables_ui(id), + # tags$div( + # style = "display: none;", + # textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId()) + # ), + easyClose = easyClose, + size = size, + footer = footer + )) +} + + + +# utils ------------------------------------------------------------------- + + +#' Get variables classes from a \code{data.frame} +#' +#' @param data a \code{data.frame} +#' +#' @return a \code{character} vector as same length as number of variables +#' @noRd +#' +#' @examples +#' +#' get_classes(mtcars) +get_classes <- function(data) { + classes <- lapply( + X = data, + FUN = function(x) { + paste(class(x), collapse = ", ") + } + ) + unlist(classes, use.names = FALSE) +} + + +#' Get count of unique values in variables of \code{data.frame} +#' +#' @param data a \code{data.frame} +#' +#' @return a \code{numeric} vector as same length as number of variables +#' @noRd +#' +#' +#' @examples +#' get_n_unique(mtcars) +get_n_unique <- function(data) { + u <- lapply(data, FUN = function(x) { + if (is.atomic(x)) { + data.table::uniqueN(x) + } else { + NA_integer_ + } + }) + unlist(u, use.names = FALSE) +} + + + +#' Add padding 0 to a vector +#' +#' @param x a \code{vector} +#' +#' @return a \code{character} vector +#' @noRd +#' +#' @examples +#' +#' pad0(1:10) +#' pad0(c(1, 15, 150, NA)) +pad0 <- function(x) { + NAs <- which(is.na(x)) + x <- formatC(x, width = max(nchar(as.character(x)), na.rm = TRUE), flag = "0") + x[NAs] <- NA + x +} + +#' Variables summary +#' +#' @param data a \code{data.frame} +#' +#' @return a \code{data.frame} +#' @noRd +#' +#' @examples +#' +#' summary_vars(iris) +#' summary_vars(mtcars) +summary_vars <- function(data) { + data <- as.data.frame(data) + datsum <- dplyr::tibble( + name = names(data), + label = lapply(data, \(.x) REDCapCAST::get_attr(.x, "label")) |> unlist(), + class = get_classes(data), + n_missing = unname(colSums(is.na(data))), + p_complete = 1 - n_missing / nrow(data), + n_unique = get_n_unique(data) + ) + + datsum +} + +add_var_toset <- function(data, var_name, default = "") { + datanames <- names(data) + datanames <- append( + x = datanames, + values = paste0(var_name, "_toset"), + after = which(datanames == var_name) + ) + data[[paste0(var_name, "_toset")]] <- default + data[, datanames] +} + +#' Modified from the datamods pacakge +#' +#' @param data data +#' +#' @param height height +#' @param selectionId selectionId +#' @param buttonId buttonId +#' +#' @examples +#' mtcars |> +#' summary_vars() |> +#' update_variables_datagrid() +#' +update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, buttonId = NULL) { + # browser() + data <- add_var_toset(data, "name", "New name") + data <- add_var_toset(data, "class", "Select") + data <- add_var_toset(data, "label", "New label") + + gridTheme <- getOption("datagrid.theme") + if (length(gridTheme) < 1) { + datamods:::apply_grid_theme() + } + on.exit(toastui::reset_grid_theme()) + + col.names <- names(data) + + std_names <- c( + "name", "name_toset", "label", "label_toset", "class", "class_toset", "n_missing", "p_complete", "n_unique" + ) |> + setNames(c( + "Name", "New name", "Label", "New label", "Class", "New class", "Missing", "Complete", "Unique" + )) + + headers <- lapply(col.names, \(.x){ + if (.x %in% std_names) { + names(std_names)[match(.x, std_names)] + } else { + .x + } + }) |> unlist() + + grid <- toastui::datagrid( + data = data, + theme = "default", + colwidths = NULL + ) + grid <- toastui::grid_columns( + grid = grid, + columns = col.names, + header = headers, + minWidth = 100 + ) + + grid <- toastui::grid_format( + grid = grid, + "p_complete", + formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}") + ) + grid <- toastui::grid_style_column( + grid = grid, + column = "name_toset", + fontStyle = "italic" + ) + grid <- toastui::grid_style_column( + grid = grid, + column = "label_toset", + fontStyle = "italic" + ) + grid <- toastui::grid_style_column( + grid = grid, + column = "class_toset", + fontStyle = "italic" + ) + + grid <- toastui::grid_filters( + grid = grid, + column = "name", + # columns = unname(std_names[std_names!="vals"]), + showApplyBtn = FALSE, + showClearBtn = TRUE, + type = "text" + ) + + # grid <- toastui::grid_columns( + # grid = grid, + # columns = "name_toset", + # editor = list(type = "text"), + # validation = toastui::validateOpts() + # ) + # + # grid <- toastui::grid_columns( + # grid = grid, + # columns = "label_toset", + # editor = list(type = "text"), + # validation = toastui::validateOpts() + # ) + # + # grid <- toastui::grid_columns( + # grid = grid, + # columns = "class_toset", + # editor = list( + # type = "radio", + # options = list( + # instantApply = TRUE, + # listItems = lapply( + # X = c("Select", "character", "factor", "numeric", "integer", "date", "datetime", "hms"), + # FUN = function(x) { + # list(text = x, value = x) + # } + # ) + # ) + # ), + # validation = toastui::validateOpts() + # ) + + grid <- toastui::grid_editor( + grid = grid, + column = "name_toset", + type = "text" + ) + grid <- toastui::grid_editor( + grid = grid, + column = "label_toset", + type = "text" + ) + grid <- toastui::grid_editor( + grid = grid, + column = "class_toset", + type = "select", + choices = c("Select", "character", "factor", "numeric", "integer", "date", "datetime", "hms") + ) + grid <- toastui::grid_editor_opts( + grid = grid, + editingEvent = "click", + actionButtonId = NULL, + session = NULL + ) + grid <- toastui::grid_selection_row( + grid = grid, + inputId = selectionId, + type = "checkbox", + return = "index" + ) + + return(grid) +} + + + +#' Convert a variable to specific new class +#' +#' @param data A \code{data.frame} +#' @param variable Name of the variable to convert +#' @param new_class Class to set +#' @param ... Other arguments passed on to methods. +#' +#' @return A \code{data.frame} +#' @noRd +#' +#' @importFrom utils type.convert +#' @importFrom rlang sym expr +#' +#' @examples +#' dat <- data.frame( +#' v1 = month.name, +#' v2 = month.abb, +#' v3 = 1:12, +#' v4 = as.numeric(Sys.Date() + 0:11), +#' v5 = as.character(Sys.Date() + 0:11), +#' v6 = as.factor(c("a", "a", "b", "a", "b", "a", "a", "b", "a", "b", "b", "a")), +#' v7 = as.character(11:22), +#' stringsAsFactors = FALSE +#' ) +#' +#' str(dat) +#' +#' str(convert_to(dat, "v3", "character")) +#' str(convert_to(dat, "v6", "character")) +#' str(convert_to(dat, "v7", "numeric")) +#' str(convert_to(dat, "v4", "date", origin = "1970-01-01")) +#' str(convert_to(dat, "v5", "date")) +#' +#' str(convert_to(dat, c("v1", "v3"), c("factor", "character"))) +#' +#' str(convert_to(dat, c("v1", "v3", "v4"), c("factor", "character", "date"), origin = "1970-01-01")) +#' +convert_to <- function(data, + variable, + new_class = c("character", "factor", "numeric", "integer", "date", "datetime", "hms"), + ...) { + new_class <- match.arg(new_class, several.ok = TRUE) + stopifnot(length(new_class) == length(variable)) + args <- list(...) + args$format <- clean_sep(args$format) + if (length(variable) > 1) { + for (i in seq_along(variable)) { + data <- convert_to(data, variable[i], new_class[i], ...) + } + return(data) + } + if (identical(new_class, "character")) { + data[[variable]] <- as.character(x = data[[variable]], ...) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(as.character(!!sym(variable)))), variable) + ) + } else if (identical(new_class, "factor")) { + data[[variable]] <- REDCapCAST::as_factor(x = data[[variable]]) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(REDCapCAST::as_factor(!!sym(variable)))), variable) + ) + } else if (identical(new_class, "numeric")) { + data[[variable]] <- as.numeric(data[[variable]], ...) + # This is the original, that would convert to character and then to numeric + # resulting in all NAs, setting as.is = FALSE would result in a numeric + # vector in order of appearance. Now it is acting like integer conversion + # data[[variable]] <- as.numeric(type.convert(data[[variable]], as.is = TRUE, ...)) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(as.numeric(!!sym(variable)))), variable) + ) + } else if (identical(new_class, "integer")) { + data[[variable]] <- as.integer(x = data[[variable]], ...) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(as.integer(!!sym(variable)))), variable) + ) + } else if (identical(new_class, "date")) { + data[[variable]] <- as.Date(x = clean_date(data[[variable]]), ...) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(as.Date(clean_date(!!sym(variable)), origin = !!args$origin, format = clean_sep(!!args$format)))), variable) + ) + } else if (identical(new_class, "datetime")) { + data[[variable]] <- as.POSIXct(x = data[[variable]], ...) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(as.POSIXct(!!sym(variable)))), variable) + ) + } else if (identical(new_class, "hms")) { + data[[variable]] <- hms::as_hms(x = data[[variable]]) + attr(data, "code_03_convert") <- c( + attr(data, "code_03_convert"), + setNames(list(expr(hms::as_hms(!!sym(variable)))), variable) + ) + } + return(data) +} + + + + + + + + +#' Get variable(s) to convert +#' +#' @param vars Output of [summary_vars()] +#' @param classes_input List of inputs containing new classes +#' +#' @return a `data.table`. +#' @noRd +#' +#' @importFrom data.table data.table as.data.table +#' +#' @examples +#' # 2 variables to convert +#' new_classes <- list( +#' "Sepal.Length" = "numeric", +#' "Sepal.Width" = "numeric", +#' "Petal.Length" = "character", +#' "Petal.Width" = "numeric", +#' "Species" = "character" +#' ) +#' get_vars_to_convert(summary_vars(iris), new_classes) +#' +#' +#' # No changes +#' new_classes <- list( +#' "Sepal.Length" = "numeric", +#' "Sepal.Width" = "numeric", +#' "Petal.Length" = "numeric", +#' "Petal.Width" = "numeric", +#' "Species" = "factor" +#' ) +#' get_vars_to_convert(summary_vars(iris), new_classes) +#' +#' # Not set = NA or "" +#' new_classes <- list( +#' "Sepal.Length" = NA, +#' "Sepal.Width" = NA, +#' "Petal.Length" = NA, +#' "Petal.Width" = NA, +#' "Species" = NA +#' ) +#' get_vars_to_convert(summary_vars(iris), new_classes) +#' +#' # Set for one var +#' new_classes <- list( +#' "Sepal.Length" = "", +#' "Sepal.Width" = "", +#' "Petal.Length" = "", +#' "Petal.Width" = "", +#' "Species" = "character" +#' ) +#' get_vars_to_convert(summary_vars(iris), new_classes) +#' +#' new_classes <- list( +#' "mpg" = "character", +#' "cyl" = "numeric", +#' "disp" = "character", +#' "hp" = "numeric", +#' "drat" = "character", +#' "wt" = "character", +#' "qsec" = "numeric", +#' "vs" = "character", +#' "am" = "numeric", +#' "gear" = "character", +#' "carb" = "integer" +#' ) +#' get_vars_to_convert(summary_vars(mtcars), new_classes) +get_vars_to_convert <- function(vars, classes_input) { + vars <- data.table::as.data.table(vars) + classes_input <- data.table::data.table( + name = names(classes_input), + class_to_set = unlist(classes_input, use.names = FALSE), + stringsAsFactors = FALSE + ) + classes_input <- classes_input[!is.na(class_to_set) & class_to_set != ""] + classes_df <- merge(x = vars, y = classes_input, by = "name") + classes_df <- classes_df[!is.na(class_to_set)] + classes_df[class != class_to_set] +} + + +#' gsub wrapper for piping with default values for separator substituting +#' +#' @param data character vector +#' @param old.sep old separator +#' @param new.sep new separator +#' +#' @returns character vector +#' @export +#' +clean_sep <- function(data, old.sep = "[-.,/]", new.sep = "-") { + gsub(old.sep, new.sep, data) +} + +#' Attempts at applying uniform date format +#' +#' @param data character string vector of possible dates +#' +#' @returns character string +#' @export +#' +clean_date <- function(data) { + data |> + clean_sep() |> + sapply(\(.x){ + if (is.na(.x)) { + .x + } else { + strsplit(.x, "-") |> + unlist() |> + lapply(\(.y){ + if (nchar(.y) == 1) paste0("0", .y) else .y + }) |> + paste(collapse = "-") + } + }) |> + unname() +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//visual_summary.R +######## + +#' Data correlations evaluation module +#' +#' @param id Module id +#' +#' @name data-missings +#' @returns Shiny ui module +#' @export +visual_summary_ui <- function(id) { + ns <- shiny::NS(id) + + shiny::tagList( + shiny::plotOutput(outputId = ns("visual_plot"), height = "70vh") + ) +} + +visual_summary_server <- function(id, + data_r=shiny::reactive(NULL), + ...) { + shiny::moduleServer( + id = id, + module = function(input, output, session) { + # ns <- session$ns + rv <- shiny::reactiveValues(data = NULL) + + shiny::bindEvent(shiny::observe({ + data <- data_r() + rv$data <- data + # vars_num <- vapply(data, \(.x){ + # is.numeric(.x) || is_datetime(.x) + # }, logical(1)) + # vars_num <- names(vars_num)[vars_num] + # shinyWidgets::updateVirtualSelect( + # inputId = "variable", + # choices = vars_num, + # selected = if (isTruthy(input$variable)) input$variable else vars_num[1] + # ) + }), data_r(), input$hidden) + + # datar <- if (is.reactive(data)) data else reactive(data) + + + # apexcharter::renderApexchart({ + # missings_apex_plot(datar(), ...) + # }) + output$visual_plot <- shiny::renderPlot(expr = { + visual_summary(data = rv$data,...) + }) + } + ) +} + +visual_summary_demo_app <- function() { + ui <- shiny::fluidPage( + shiny::actionButton( + inputId = "modal_missings", + label = "Visual summary", + width = "100%", + disabled = FALSE + ) + ) + server <- function(input, output, session) { + data_demo <- mtcars + data_demo[sample(1:32, 10), "cyl"] <- NA + data_demo[sample(1:32, 8), "vs"] <- NA + + visual_summary_server(id = "data", data = shiny::reactive(data_demo)) + + observeEvent(input$modal_missings, { + tryCatch( + { + modal_visual_summary(id = "data") + }, + error = function(err) { + showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err") + } + ) + }) + } + shiny::shinyApp(ui, server) +} + +visual_summary_demo_app() + + +modal_visual_summary <- function(id, + title = "Visual overview of data classes and missing observations", + easyClose = TRUE, + size = "xl", + footer = NULL, + ...) { + showModal(modalDialog( + title = tagList(title, datamods:::button_close_modal()), + visual_summary_ui(id = id), + easyClose = easyClose, + size = size, + footer = footer + )) +} + + +## Slow with many observations... + +#' Plot missings and class with apexcharter +#' +#' @param data data frame +#' +#' @returns An [apexchart()] `htmlwidget` object. +#' @export +#' +#' @examples +#' data_demo <- mtcars +#' data_demo[2:4, "cyl"] <- NA +#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot() +#' data_demo |> missings_apex_plot() +#' mtcars |> missings_apex_plot(animation = TRUE) +#' # dplyr::storms |> missings_apex_plot() +#' visdat::vis_dat(dplyr::storms) +missings_apex_plot <- function(data, animation = FALSE, ...) { + l <- data_summary_gather(data, ...) + + df_plot <- l$data + + out <- apexcharter::apex( + data = df_plot, + type = "heatmap", + mapping = apexcharter::aes(x = variable, y = rows, fill = valueType_num), + ... + ) |> + apexcharter::ax_stroke(width = NULL) |> + apexcharter::ax_plotOptions( + heatmap = apexcharter::heatmap_opts( + radius = 0, + enableShades = FALSE, + colorScale = list( + ranges = l$labels + ), + useFillColorAsStroke = TRUE + ) + ) |> + apexcharter::ax_dataLabels(enabled = FALSE) |> + apexcharter::ax_tooltip( + enabled = FALSE, + intersect = FALSE + ) + + if (!isTRUE(animation)) { + out <- out |> + apexcharter::ax_chart(animations = list(enabled = FALSE)) + } + + out +} + + + +#' Ggplot2 data summary visualisation based on visdat::vis_dat. +#' +#' @param data data +#' @param ... optional arguments passed to data_summary_gather() +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' data_demo <- mtcars +#' data_demo[sample(1:32, 10), "cyl"] <- NA +#' data_demo[sample(1:32, 8), "vs"] <- NA +#' visual_summary(data_demo) +#' visual_summary(data_demo, palette.fun = scales::hue_pal()) +#' visual_summary(dplyr::storms) +#' visual_summary(dplyr::storms, summary.fun = data_type) +visual_summary <- function(data, legend.title = "Data class", ...) { + l <- data_summary_gather(data, ...) + + df <- l$data + + df$valueType <- factor(df$valueType, levels = names(l$colors)) + df$variable <- factor(df$variable, levels = unique_short(names(data))) + + ggplot2::ggplot(data = df, ggplot2::aes(x = variable, y = rows)) + + ggplot2::geom_raster(ggplot2::aes(fill = valueType)) + + ggplot2::theme_minimal() + + ggplot2::theme(axis.text.x = ggplot2::element_text( + angle = 45, + vjust = 1, hjust = 1 + )) + + ggplot2::scale_fill_manual(values = l$colors) + + ggplot2::labs(x = "", y = "Observations") + + ggplot2::scale_y_reverse() + + ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0.5)) + + ggplot2::guides(colour = "none") + + ggplot2::guides(fill = ggplot2::guide_legend(title = legend.title)) + + # change the limits etc. + ggplot2::guides(fill = ggplot2::guide_legend(title = "Type")) + + # add info about the axes + ggplot2::scale_x_discrete(position = "top") + + ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0)) + + ggplot2::theme( + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + text = ggplot2::element_text(size = 18), + plot.title = ggplot2::element_blank() + ) +} + +#' Data summary for printing visual summary +#' +#' @param data data.frame +#' @param fun summary function. Default is "class" +#' @param palette.fun optionally use specific palette functions. First argument +#' has to be the length. +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' mtcars |> data_summary_gather() +data_summary_gather <- function(data, summary.fun = class, palette.fun = viridisLite::viridis) { + df_plot <- setNames(data, unique_short(names(data))) |> + purrr::map_df(\(x){ + ifelse(is.na(x), + yes = NA, + no = glue::glue_collapse(summary.fun(x), + sep = "\n" + ) + ) + }) |> + dplyr::mutate(rows = dplyr::row_number()) |> + tidyr::pivot_longer( + cols = -rows, + names_to = "variable", values_to = "valueType", values_transform = list(valueType = as.character) + ) |> + dplyr::arrange(rows, variable, valueType) + + + df_plot$valueType_num <- df_plot$valueType |> + forcats::as_factor() |> + as.numeric() + + df_plot$valueType[is.na(df_plot$valueType)] <- "NA" + df_plot$valueType_num[is.na(df_plot$valueType_num)] <- max(df_plot$valueType_num, na.rm = TRUE) + 1 + + labels <- setNames(unique(df_plot$valueType_num), unique(df_plot$valueType)) |> sort() + + if (any(df_plot$valueType == "NA")) { + colors <- setNames(c(palette.fun(length(labels) - 1), "#999999"), names(labels)) + } else { + colors <- setNames(palette.fun(length(labels)), names(labels)) + } + + + label_list <- labels |> + purrr::imap(\(.x, .i){ + list( + from = .x, + to = .x, + color = colors[[.i]], + name = .i + ) + }) |> + setNames(NULL) + + list(data = df_plot, colors = colors, labels = label_list) +} + + + +#' Create unique short names of character vector items based on index +#' +#' @description +#' The function will prefer original names, and only append index to long +#' strings. +#' +#' +#' @param data character vector +#' @param max maximum final name length +#' +#' @returns character vector +#' @export +#' +#' @examples +#' c("kahdleidnsallskdj", "hej") |> unique_short() +unique_short <- function(data, max = 15) { + purrr::imap(data, \(.x, .i){ + if (nchar(.x) > max) { + glue::glue("{substr(.x,1,(max-(nchar(.i)+1)))}_{.i}") + } else { + .x + } + }) |> unlist() +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//wide2long.R +######## + +#' Alternative pivoting method for easily pivoting based on name pattern +#' +#' @description +#' This function requires and assumes a systematic naming of variables. +#' For now only supports one level pivoting. Adding more levels would require +#' an added "ignore" string pattern or similarly. Example 2. +#' +#' +#' @param data data +#' @param pattern pattern(s) to match. Character vector of length 1 or more. +#' @param type type of match. can be one of "prefix","infix" or "suffix". +#' @param id.col ID column. Will fill ID for all. Column name or numeric index. +#' Default is "1", first column. +#' @param instance.name +#' +#' @returns data.frame +#' @export +#' +#' @examples +#' data.frame( +#' 1:20, sample(70:80, 20, TRUE), +#' sample(70:100, 20, TRUE), +#' sample(70:100, 20, TRUE), +#' sample(170:200, 20, TRUE) +#' ) |> +#' setNames(c("id", "age", "weight_0", "weight_1", "height_1")) |> +#' wide2long(pattern = c("_0", "_1"), type = "suffix") +#' data.frame( +#' 1:20, sample(70:80, 20, TRUE), +#' sample(70:100, 20, TRUE), +#' sample(70:100, 20, TRUE), +#' sample(170:200, 20, TRUE) +#' ) |> +#' setNames(c("id", "age", "weight_0", "weight_a_1", "height_b_1")) |> +#' wide2long(pattern = c("_0", "_1"), type = "suffix") +#' # Optional filling of missing values by last observation carried forward +#' # Needed for mmrm analyses +#' long_missings |> +#' # Fills record ID assuming none are missing +#' tidyr::fill(record_id) |> +#' # Grouping by ID for the last step +#' dplyr::group_by(record_id) |> +#' # Filling missing data by ID +#' tidyr::fill(names(long_missings)[!names(long_missings) %in% new_names]) |> +#' # Remove grouping +#' dplyr::ungroup() +wide2long <- function( + data, + pattern, + type = c("prefix", "infix", "suffix"), + id.col = 1, + instance.name = "instance") { + type <- match.arg(type) + + ## Give the unique suffix names to use for identifying repeated measures + # suffixes <- c("_0", "_1") + + ## If no ID column is present, one is added + if (id.col == "none" | is.null(id.col)) { + data <- stats::setNames( + data.frame(seq_len(nrow(data)), data), + make.names(c("id", names(data)), unique = TRUE) + ) + id.col <- 1 + } +# browser() + ## Relevant columns are determined based on suffixes + cols <- names(data)[grepl_fix(names(data), pattern = pattern, type = type)] + + ## New colnames are created by removing suffixes + new_names <- unique(gsub(paste(pattern, collapse = "|"), "", cols)) + + out <- split(data, seq_len(nrow(data))) |> # Splits dataset by row + # Starts data modifications for each subject + lapply(\(.x){ + ## Pivots data with repeated measures as determined by the defined suffixes + long_ls <- split.default( + # Subset only repeated data + .x[cols], + # ... and split by meassure + gsub(paste(new_names, collapse = "|"), "", cols) + ) |> + # Sort data by order of given suffixes to ensure chronology + sort_by(pattern) |> + # New colnames are applied + lapply(\(.y){ + setNames( + .y, + gsub(paste(pattern, collapse = "|"), "", names(.y)) + ) + }) + + # Subsets non-pivotted data (this is assumed to belong to same ) + single <- .x[-match(cols, names(.x))] + + # Extends with empty rows to get same dimensions as long data + single[(nrow(single) + 1):length(long_ls), ] <- NA + + # Fills ID col + single[id.col] <- single[1, id.col] + + # Everything is merged together + merged <- dplyr::bind_cols( + single, + # Instance names are defined as suffixes without leading non-characters + REDCapCAST::as_factor(data.frame(gsub( + "^[^[:alnum:]]+", "", + names(long_ls) + ))), + dplyr::bind_rows(long_ls) + ) + + # Ensure unique new names based on supplied + colnames(merged) <- make.names( + c( + names(single), + instance.name, + names(merged)[(NCOL(single) + 2):NCOL(merged)] + ), + unique = TRUE + ) + + merged + }) |> dplyr::bind_rows() + + rownames(out) <- NULL + + out +} + + +#' Matches pattern to vector based on match type +#' +#' @param data vector +#' @param pattern pattern(s) to match. Character vector of length 1 or more. +#' @param type type of match. can be one of "prefix","infix" or "suffix". +#' +#' @returns logical vector +#' @export +#' +#' @examples +#' c("id", "age", "weight_0", "weight_1") |> grepl_fix(pattern = c("_0", "_1"), type = "suffix") +grepl_fix <- function(data, pattern, type = c("prefix", "infix", "suffix")) { + type <- match.arg(type) + + if (type == "prefix") { + grepl(paste0("^(", paste(pattern, collapse = "|"), ")*"), data) + } else if (type == "suffix") { + grepl(paste0("*(", paste(pattern, collapse = "|"), ")$"), data) + } else if (type == "infix") { + grepl(paste0("*(", paste(pattern, collapse = "|"), ")*"), data) + } +} + + +######## +#### Current file: /Users/au301842/FreesearchR/dev/header_include.R +######## + +header_include <- function(){ + shiny::tags$head( + includeHTML("www/umami-app.html"), + tags$link(rel = "stylesheet", type = "text/css", href = "style.css")) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/dev/dev_banner.R +######## + +dev_banner <- function(){ + NULL + } + + +######## +#### Current file: /Users/au301842/FreesearchR/app/ui.R +######## + +# ns <- NS(id) + + + +ui_elements <- list( + ############################################################################## + ######### + ######### Home panel + ######### + ############################################################################## + "home" = bslib::nav_panel( + title = "FreesearchR", + shiny::fluidRow( + ## On building the dev-version for shinyapps.io, the dev_banner() is redefined + ## Default just output "NULL" + ## This could probably be achieved more legantly, but this works. + dev_banner(), + shiny::column(width = 2), + shiny::column( + width = 8, + shiny::markdown(readLines("www/intro.md")), + shiny::column(width = 2) + ) + ), + icon = shiny::icon("home") + ), + ############################################################################## + ######### + ######### Import panel + ######### + ############################################################################## + "import" = bslib::nav_panel( + title = "Import", + shiny::fluidRow( + shiny::column(width = 2), + shiny::column( + width = 8, + shiny::h4("Choose your data source"), + shiny::br(), + # shiny::uiOutput(outputId = "source"), + shinyWidgets::radioGroupButtons( + inputId = "source", + selected = "file", + choices = c( + "File upload" = "file", + "REDCap server export" = "redcap", + "Local or sample data" = "env" + ), + size = "lg" + ), + shiny::tags$script('document.querySelector("#source div").style.width = "100%"'), + shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."), + shiny::br(), + shiny::br(), + shiny::conditionalPanel( + condition = "input.source=='file'", + import_file_ui( + id = "file_import", + layout_params = "dropdown", + # title = "Choose a datafile to upload", + file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".ods", ".dta") + ) + ), + shiny::conditionalPanel( + condition = "input.source=='redcap'", + shinyWidgets::alert( + id = "redcap-warning", + status = "info", + shiny::tags$h2(shiny::markdown("Careful with sensitive data")), + shiny::tags$p("The", shiny::tags$i(shiny::tags$b("FreesearchR")), "app only stores data for analyses, but please only use with sensitive data when running locally.", "", shiny::tags$a("Read more here", href = "https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine"), "."), + dismissible = TRUE + ), + m_redcap_readUI( + id = "redcap_import", + title = "" + ) + ), + shiny::conditionalPanel( + condition = "input.source=='env'", + import_globalenv_ui(id = "env", title = NULL) + ), + # shiny::conditionalPanel( + # condition = "input.source=='redcap'", + # DT::DTOutput(outputId = "redcap_prev") + # ), + shiny::conditionalPanel( + condition = "output.data_loaded == true", + shiny::br(), + shiny::actionButton( + inputId = "modal_initial_view", + label = "Quick overview", + width = "100%", + icon = shiny::icon("binoculars"), + disabled = FALSE + ), + shiny::br(), + shiny::br(), + shiny::h5("Select variables for final import"), + shiny::fluidRow( + shiny::column( + width = 6, + shiny::p("Exclude incomplete variables:"), + shiny::br(), + shinyWidgets::noUiSliderInput( + inputId = "complete_cutoff", + label = NULL, + update_on = "end", + min = 0, + max = 100, + step = 5, + value = 30, + format = shinyWidgets::wNumbFormat(decimals = 0), + color = datamods:::get_primary_color() + ), + shiny::helpText("Only include variables missing less observations than the specified percentage."), + shiny::br() + ), + shiny::column( + width = 6, + shiny::p("Manual selection:"), + shiny::br(), + shiny::uiOutput(outputId = "import_var"), + shiny::br() + ) + ), + shiny::uiOutput(outputId = "data_info_import", inline = TRUE), + shiny::br(), + shiny::br(), + shiny::actionButton( + inputId = "act_start", + label = "Start", + width = "100%", + icon = shiny::icon("play"), + disabled = TRUE + ), + shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'), + shiny::br(), + shiny::br() + ), + shiny::column(width = 2) + ), + shiny::br(), + shiny::br() + ) + ), + ############################################################################## + ######### + ######### Data overview panel + ######### + ############################################################################## + "overview" = + # bslib::nav_panel_hidden( + bslib::nav_panel( + # value = "overview", + title = "Data", + bslib::navset_bar( + fillable = TRUE, + bslib::nav_panel( + title = "Overview", + tags$h3("Overview and filtering"), + fluidRow( + shiny::column( + width = 9, + shiny::uiOutput(outputId = "data_info", inline = TRUE), + shiny::tags$p( + "Below is a short summary table, on the right you can click to visualise data classes or browse data and create different data filters." + ) + ), + shiny::column( + width = 3, + shiny::actionButton( + inputId = "modal_visual_overview", + label = "Visual overview", + width = "100%", + disabled = TRUE + ), + shiny::br(), + shiny::br(), + shiny::actionButton( + inputId = "modal_browse", + label = "Browse data", + width = "100%", + disabled = TRUE + ), + shiny::br(), + shiny::br() + ) + ), + fluidRow( + shiny::column( + width = 9, + data_summary_ui(id = "data_summary"), + shiny::br(), + shiny::br(), + shiny::br(), + shiny::br(), + shiny::br() + ), + shiny::column( + width = 3, + # shiny::actionButton( + # inputId = "modal_missings", + # label = "Visual overview", + # width = "100%", + # disabled = TRUE + # ), + # shiny::br(), + # shiny::br(), + # shiny::actionButton( + # inputId = "modal_browse", + # label = "Browse data", + # width = "100%", + # disabled = TRUE + # ), + # shiny::br(), + # shiny::br(), + shiny::tags$h6("Filter data types"), + shiny::uiOutput( + outputId = "column_filter" + ), + shiny::helpText("Read more on how ", tags$a( + "data types", + href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + target = "_blank", + rel = "noopener noreferrer" + ), " are defined."), + shiny::br(), + shiny::br(), + shiny::tags$h6("Filter observations"), + shiny::tags$p("Filter on observation level"), + IDEAFilter::IDEAFilter_ui("data_filter"), + shiny::br(), + shiny::br() + ) + ), + shiny::br(), + shiny::br(), + # shiny::br(), + # shiny::br(), + shiny::br() + ), + bslib::nav_panel( + title = "Modify", + tags$h3("Subset, rename and convert variables"), + fluidRow( + shiny::column( + width = 9, + shiny::tags$p( + shiny::markdown("Below, are several options for simple data manipulation like update variables by renaming, creating new labels (for nicer tables in the report) and changing variable classes (numeric, factor/categorical etc.)."), + shiny::markdown("There are more advanced options to modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code. At the bottom you can restore the original data."), + shiny::markdown("Please note that data modifications are applied before any filtering.") + ) + ) + ), + # shiny::tags$br(), + update_variables_ui("modal_variables"), + shiny::tags$br(), + shiny::tags$br(), + shiny::tags$h4("Advanced data manipulation"), + shiny::tags$p("Below options allow more advanced varaible manipulations."), + shiny::tags$br(), + shiny::tags$br(), + shiny::fluidRow( + shiny::column( + width = 4, + shiny::actionButton( + inputId = "modal_update", + label = "Reorder factor levels", + width = "100%" + ), + shiny::tags$br(), + shiny::helpText("Reorder the levels of factor/categorical variables."), + shiny::tags$br(), + shiny::tags$br() + ), + shiny::column( + width = 4, + shiny::actionButton( + inputId = "modal_cut", + label = "New factor", + width = "100%" + ), + shiny::tags$br(), + shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."), + shiny::tags$br(), + shiny::tags$br() + ), + shiny::column( + width = 4, + shiny::actionButton( + inputId = "modal_column", + label = "New variable", + width = "100%" + ), + shiny::tags$br(), + shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression.")), + shiny::tags$br(), + shiny::tags$br() + ) + ), + tags$h4("Compare modified data to original"), + shiny::tags$br(), + shiny::tags$p( + "Raw print of the original vs the modified data." + ), + shiny::tags$br(), + shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b("Original data:"), + # verbatimTextOutput("original"), + shiny::verbatimTextOutput("original_str") + ), + shiny::column( + width = 6, + shiny::tags$b("Modified data:"), + # verbatimTextOutput("modified"), + shiny::verbatimTextOutput("modified_str") + ) + ), + shiny::tags$br(), + shiny::actionButton( + inputId = "data_reset", + label = "Restore original data", + width = "100%" + ), + shiny::tags$br(), + shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."), + shiny::tags$br() + ) + ) + ), + ############################################################################## + ######### + ######### Descriptive analyses panel + ######### + ############################################################################## + "describe" = + bslib::nav_panel( + title = "Evaluate", + id = "navdescribe", + bslib::navset_bar( + title = "", + sidebar = bslib::sidebar( + shiny::uiOutput(outputId = "data_info_nochar", inline = TRUE), + bslib::accordion( + open = "acc_chars", + multiple = FALSE, + bslib::accordion_panel( + value = "acc_chars", + title = "Characteristics", + icon = bsicons::bs_icon("table"), + shiny::uiOutput("strat_var"), + shiny::helpText("Only factor/categorical variables are available for stratification. Go back to the 'Data' tab to reclass a variable if it's not on the list."), + shiny::conditionalPanel( + condition = "input.strat_var!='none'", + shiny::radioButtons( + inputId = "add_p", + label = "Compare strata?", + selected = "no", + inline = TRUE, + choices = list( + "No" = "no", + "Yes" = "yes" + ) + ), + shiny::helpText("Option to perform statistical comparisons between strata in baseline table.") + ), + shiny::br(), + shiny::br(), + shiny::actionButton( + inputId = "act_eval", + label = "Evaluate", + width = "100%", + icon = shiny::icon("calculator"), + disabled = TRUE + ) + ), + bslib::accordion_panel( + vlaue = "acc_cor", + title = "Correlations", + icon = bsicons::bs_icon("bounding-box"), + shiny::uiOutput("outcome_var_cor"), + shiny::helpText("To avoid evaluating the correlation of the outcome variable, this can be excluded from the plot or select 'none'."), + shiny::br(), + shinyWidgets::noUiSliderInput( + inputId = "cor_cutoff", + label = "Correlation cut-off", + min = 0, + max = 1, + step = .01, + value = .8, + format = shinyWidgets::wNumbFormat(decimals = 2), + color = datamods:::get_primary_color() + ), + shiny::helpText("Set the cut-off for considered 'highly correlated'.") + ), + bslib::accordion_panel( + vlaue = "acc_mis", + title = "Missings", + icon = bsicons::bs_icon("x-circle"), + shiny::uiOutput("missings_var"), + shiny::helpText("To consider if daata is missing by random, choose the outcome/dependent variable, if it has any missings to evaluate if there is a significant difference across other variables depending on missing data or not.") + ) + ) + ), + bslib::nav_panel( + title = "Characteristics", + gt::gt_output(outputId = "table1") + ), + bslib::nav_panel( + title = "Correlations", + data_correlations_ui(id = "correlations", height = 600) + ), + bslib::nav_panel( + title = "Missings", + data_missings_ui(id = "missingness") + ) + ) + ), + ############################################################################## + ######### + ######### Download panel + ######### + ############################################################################## + "visuals" = bslib::nav_panel( + title = "Visuals", + id = "navvisuals", + do.call( + bslib::navset_bar, + c( + data_visuals_ui("visuals"), + shiny::tagList( + bslib::nav_spacer(), + bslib::nav_item( + # shiny::img(shiny::icon("book")), + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + "Notes (external)", + target = "_blank", + rel = "noopener noreferrer" + ) + ) + ) + ) + ) + ), + ############################################################################## + ######### + ######### Regression analyses panel + ######### + ############################################################################## + "analyze" = + bslib::nav_panel( + title = "Regression", + id = "navanalyses", + do.call( + bslib::navset_bar, + regression_ui("regression") + ) + ), + ############################################################################## + ######### + ######### Download panel + ######### + ############################################################################## + "download" = + bslib::nav_panel( + title = "Download", + id = "navdownload", + shiny::fluidRow( + shiny::column(width = 2), + shiny::column( + width = 8, + shiny::fluidRow( + shiny::column( + width = 6, + shiny::h4("Report"), + shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."), + shiny::br(), + shiny::br(), + shiny::selectInput( + inputId = "output_type", + label = "Output format", + selected = NULL, + choices = list( + "MS Word" = "docx", + "LibreOffice" = "odt" + # , + # "PDF" = "pdf", + # "All the above" = "all" + ) + ), + shiny::br(), + # Button + shiny::downloadButton( + outputId = "report", + label = "Download report", + icon = shiny::icon("download") + ) + # shiny::helpText("If choosing to output to MS Word, please note, that when opening the document, two errors will pop-up. Choose to repair and choose not to update references. The issue is being worked on. You can always choose LibreOffice instead."), + ), + shiny::column( + width = 6, + shiny::h4("Data"), + shiny::helpText("Choose your favourite output data format to download the modified data."), + shiny::br(), + shiny::br(), + shiny::selectInput( + inputId = "data_type", + label = "Data format", + selected = NULL, + choices = list( + "R" = "rds", + "stata" = "dta", + "CSV" = "csv" + ) + ), + shiny::helpText("No metadata is saved when exporting to csv."), + shiny::br(), + shiny::br(), + # Button + shiny::downloadButton( + outputId = "data_modified", + label = "Download data", + icon = shiny::icon("download") + ) + ) + ), + shiny::br(), + shiny::br(), + shiny::h4("Code snippets"), + shiny::tags$p("Below are the code bits used to create the final data set and the main analyses."), + shiny::tags$p("This can be used as a starting point for learning to code and for reproducibility."), + shiny::tagList( + lapply( + paste0("code_", c( + "import", "format", "data", "variables", "filter", "table1", "univariable", "multivariable" + )), + \(.x)shiny::htmlOutput(outputId = .x) + ) + ), + shiny::tags$br(), + shiny::br() + ), + shiny::column(width = 2) + ) + ), + ############################################################################## + ######### + ######### Feedback link + ######### + ############################################################################## + "feedback" = bslib::nav_item( + # shiny::img(shiny::icon("book")), + shiny::tags$a( + href = "https://redcap.au.dk/surveys/?s=JPCLPTXYDKFA8DA8", + "Feedback", shiny::icon("arrow-up-right-from-square"), + target = "_blank", + rel = "noopener noreferrer" + ) + ), + ############################################################################## + ######### + ######### Documentation link + ######### + ############################################################################## + "docs" = bslib::nav_item( + # shiny::img(shiny::icon("book")), + shiny::tags$a( + href = "https://agdamsbo.github.io/FreesearchR/", + "Docs", shiny::icon("arrow-up-right-from-square"), + target = "_blank", + rel = "noopener noreferrer" + ) + ) + # bslib::nav_panel( + # title = "Documentation", + # # shiny::tags$iframe("www/docs.html", height=600, width=535), + # shiny::htmlOutput("docs_file"), + # shiny::br() + # ) +) +# Initial attempt at creating light and dark versions +light <- custom_theme() +dark <- custom_theme( + bg = "#000", + fg = "#fff" +) + +# Fonts to consider: +# https://webdesignerdepot.com/17-open-source-fonts-youll-actually-love/ + +ui <- bslib::page_fixed( + prismDependencies, + prismRDependency, + header_include(), + ## This adds the actual favicon + ## png and ico versions are kept for compatibility + shiny::tags$head(tags$link(rel = "shortcut icon", href = "favicon.svg")), + title = "FreesearchR", + theme = light, + shiny::useBusyIndicators(), + shinyjs::useShinyjs(), + shiny::div( + id = "loading_page", + # shiny::h1("Loading the FreesearchR app..."), + shinybusy::add_busy_spinner(position = "full-page") + ), + shinyjs::hidden( + shiny::div( + id = "main_content", + bslib::page_navbar( + id = "main_panel", + ui_elements$home, + ui_elements$import, + ui_elements$overview, + ui_elements$describe, + ui_elements$visuals, + ui_elements$analyze, + ui_elements$download, + bslib::nav_spacer(), + ui_elements$feedback, + ui_elements$docs, + fillable = FALSE, + footer = shiny::tags$footer( + style = "background-color: #14131326; padding: 4px; text-align: center; bottom: 0; width: 100%;", + shiny::p( + style = "margin: 1", + "Data is only stored for analyses and deleted when the app is closed.", shiny::markdown("Consider [running ***FreesearchR*** locally](https://agdamsbo.github.io/FreesearchR/#run-locally-on-your-own-machine) if working with sensitive data.") + ), + shiny::p( + style = "margin: 1; color: #888;", + shiny::tags$a("Docs", href = "https://agdamsbo.github.io/FreesearchR/", target = "_blank", rel = "noopener noreferrer"), " | ", hosted_version(), " | ", shiny::tags$a("License: AGPLv3", href = "https://github.com/agdamsbo/FreesearchR/blob/main/LICENSE.md", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Source", href = "https://github.com/agdamsbo/FreesearchR/", target = "_blank", rel = "noopener noreferrer"), " | ", shiny::tags$a("Share feedback", href = "https://redcap.au.dk/surveys/?s=JPCLPTXYDKFA8DA8", target = "_blank", rel = "noopener noreferrer") + ), + ) + ) + ) + ) +) + + +######## +#### Current file: /Users/au301842/FreesearchR/app/server.R +######## + +data(mtcars) + +# trial <- gtsummary::trial +# starwars <- dplyr::starwars +# +# mtcars_na <- rbind(mtcars,NA,NA) + +# thematic::thematic_shiny() + +load_data <- function() { + Sys.sleep(1) + shinyjs::hide("loading_page") + shinyjs::show("main_content") +} + +# is_local = is.na(Sys.getenv('SHINY_SERVER_VERSION', NA)) + +server <- function(input, output, session) { + ## Listing files in www in session start to keep when ending and removing + ## everything else. + files.to.keep <- list.files("www/") + + load_data() + + ############################################################################## + ######### + ######### Night mode (just very popular, not really needed) + ######### + ############################################################################## + + # observeEvent(input$dark_mode,{ + # session$setCurrentTheme( + # if (isTRUE(input$dark_mode)) dark else light + # )}) + + # observe({ + # if(input$dark_mode==TRUE) + # session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5))) + # if(input$dark_mode==FALSE) + # session$setCurrentTheme(bs_theme_update(theme = custom_theme(version = 5, bg = "#000",fg="#fff"))) + # }) + + + ############################################################################## + ######### + ######### Setting reactive values + ######### + ############################################################################## + + rv <- shiny::reactiveValues( + list = list(), + regression = NULL, + missings = NULL, + ds = NULL, + local_temp = NULL, + ready = NULL, + test = "no", + data_original = NULL, + data_temp = NULL, + data = NULL, + data_variables = NULL, + data_filtered = NULL, + models = NULL, + code = list() + ) + + ############################################################################## + ######### + ######### Data import section + ######### + ############################################################################## + + data_file <- import_file_server( + id = "file_import", + show_data_in = "popup", + trigger_return = "change", + return_class = "data.frame" + ) + + shiny::observeEvent(data_file$data(), { + shiny::req(data_file$data()) + rv$data_temp <- data_file$data() + rv$code <- modifyList(x = rv$code, list(import = data_file$code())) + }) + + from_redcap <- m_redcap_readServer( + id = "redcap_import" + ) + + shiny::observeEvent(from_redcap$data(), { + rv$data_temp <- from_redcap$data() + rv$code <- modifyList(x = rv$code, list(import = from_redcap$code())) + }) + + from_env <- datamods::import_globalenv_server( + id = "env", + trigger_return = "change", + btn_show_data = FALSE, + reset = reactive(input$hidden) + ) + + shiny::observeEvent(from_env$data(), { + shiny::req(from_env$data()) + + rv$data_temp <- from_env$data() + rv$code <- modifyList(x = rv$code, list(import = from_env$name())) + }) + + visual_summary_server( + id = "initial_summary", + data_r = shiny::reactive({ + shiny::req(rv$data_temp) + default_parsing(rv$data_temp) + }), + palette.fun = FreesearchR_palette + ) + + observeEvent(input$modal_initial_view, { + tryCatch( + { + modal_visual_summary( + id = "initial_summary", + footer = NULL, + size = "xl" + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error showing missingness: ", err), type = "err") + } + ) + }) + + output$import_var <- shiny::renderUI({ + shiny::req(rv$data_temp) + + preselect <- names(rv$data_temp)[sapply(rv$data_temp, missing_fraction) <= (input$complete_cutoff / 100)] + + shinyWidgets::virtualSelectInput( + inputId = "import_var", + label = "Select variables to include", + selected = preselect, + choices = names(rv$data_temp), + updateOn = "change", + multiple = TRUE, + search = TRUE, + showValueAsTags = TRUE + ) + }) + + output$data_loaded <- shiny::reactive({ + !is.null(rv$data_temp) + }) + + shiny::observeEvent(input$source, { + rv$data_temp <- NULL + }) + + shiny::outputOptions(output, "data_loaded", suspendWhenHidden = FALSE) + + shiny::observeEvent( + eventExpr = list( + input$import_var, + input$complete_cutoff, + rv$data_temp + ), + handlerExpr = { + shiny::req(rv$data_temp) + shiny::req(input$import_var) + # browser() + temp_data <- rv$data_temp + if (all(input$import_var %in% names(temp_data))) { + temp_data <- temp_data |> dplyr::select(input$import_var) + } + + rv$data_original <- temp_data |> + default_parsing() + + rv$code$import <- rv$code$import |> + expression_string(assign.str = "df <-") + + rv$code$format <- list( + "df", + rlang::expr(dplyr::select(dplyr::all_of(!!input$import_var))), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") + ) |> + lapply(expression_string) |> + pipe_string() |> + expression_string(assign.str = "df <-") + + rv$code$filter <- NULL + rv$code$modify <- NULL + }, ignoreNULL = FALSE + ) + + output$data_info_import <- shiny::renderUI({ + shiny::req(rv$data_original) + data_description(rv$data_original) + }) + + ## Activating action buttons on data imported + shiny::observeEvent(rv$data_original, { + if (is.null(rv$data_original) | NROW(rv$data_original) == 0) { + shiny::updateActionButton(inputId = "act_start", disabled = TRUE) + shiny::updateActionButton(inputId = "modal_browse", disabled = TRUE) + shiny::updateActionButton(inputId = "modal_visual_overview", disabled = TRUE) + shiny::updateActionButton(inputId = "act_eval", disabled = TRUE) + } else { + shiny::updateActionButton(inputId = "act_start", disabled = FALSE) + shiny::updateActionButton(inputId = "modal_browse", disabled = FALSE) + shiny::updateActionButton(inputId = "modal_visual_overview", disabled = FALSE) + shiny::updateActionButton(inputId = "act_eval", disabled = FALSE) + } + }) + + ############################################################################## + ######### + ######### Data modification section + ######### + ############################################################################## + + shiny::observeEvent( + eventExpr = list( + rv$data_original + ), + handlerExpr = { + shiny::req(rv$data_original) + + rv$data <- rv$data_original + } + ) + + ## For now this solution work, but I would prefer to solve this with the above + shiny::observeEvent(input$reset_confirm, + { + if (isTRUE(input$reset_confirm)) { + shiny::req(rv$data_original) + rv$data <- rv$data_original + rv$code$filter <- NULL + rv$code$variables <- NULL + rv$code$modify <- NULL + } + }, + ignoreNULL = TRUE + ) + + + shiny::observeEvent(input$data_reset, { + shinyWidgets::ask_confirmation( + cancelOnDismiss = TRUE, + inputId = "reset_confirm", + title = "Please confirm data reset?", + type = "warning" + ) + }) + + ######### + ######### Modifications + ######### + + ## Using modified version of the datamods::cut_variable_server function + ## Further modifications are needed to have cut/bin options based on class of variable + ## Could be defined server-side + + output$data_info <- shiny::renderUI({ + shiny::req(data_filter()) + data_description(data_filter(), "The filtered data") + }) + + ######### Create factor + + shiny::observeEvent( + input$modal_cut, + modal_cut_variable("modal_cut", title = "Create new factor") + ) + + data_modal_cut <- cut_variable_server( + id = "modal_cut", + data_r = shiny::reactive(rv$data) + ) + + shiny::observeEvent(data_modal_cut(), { + rv$data <- data_modal_cut() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ######### Modify factor + + shiny::observeEvent( + input$modal_update, + datamods::modal_update_factor(id = "modal_update", title = "Reorder factor levels") + ) + + data_modal_update <- datamods::update_factor_server( + id = "modal_update", + data_r = reactive(rv$data) + ) + + shiny::observeEvent(data_modal_update(), { + shiny::removeModal() + rv$data <- data_modal_update() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ######### Create column + + shiny::observeEvent( + input$modal_column, + modal_create_column( + id = "modal_column", + footer = shiny::markdown("This window is aimed at advanced users and require some *R*-experience!"), + title = "Create new variables" + ) + ) + data_modal_r <- create_column_server( + id = "modal_column", + data_r = reactive(rv$data) + ) + shiny::observeEvent( + data_modal_r(), + { + rv$data <- data_modal_r() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + } + ) + + ######### Subset, rename, reclass + + updated_data <- update_variables_server( + id = "modal_variables", + data = shiny::reactive(rv$data), + return_data_on_init = FALSE + ) + + shiny::observeEvent(updated_data(), { + rv$data <- updated_data() + rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + ### Column filter + ### Completely implemented, but it takes a little considering where in the + ### data flow to implement, as it will act destructively on previous + ### manipulations + + output$column_filter <- shiny::renderUI({ + shiny::req(rv$data) + # c("dichotomous", "ordinal", "categorical", "datatime", "continuous") + shinyWidgets::virtualSelectInput( + inputId = "column_filter", + label = "Select data types to include", + selected = unique(data_type(rv$data)), + choices = unique(data_type(rv$data)), + updateOn = "change", + multiple = TRUE, + search = FALSE, + showValueAsTags = TRUE + ) + }) + + shiny::observe({ + # shiny::req(input$column_filter) + out <- data_type_filter(rv$data, input$column_filter) + rv$data_variables <- out + if (!is.null(input$column_filter)) { + rv$code$variables <- attr(out, "code") + } + # rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") + }) + + + ######### Data filter + # IDEAFilter has the least cluttered UI, but might have a License issue + # Consider using shinyDataFilter, though not on CRAN + data_filter <- IDEAFilter::IDEAFilter("data_filter", + data = shiny::reactive(rv$data_variables), + verbose = TRUE + ) + + shiny::observeEvent( + list( + shiny::reactive(rv$data_variables), + shiny::reactive(rv$data_original), + data_filter(), + # regression_vars(), + input$complete_cutoff + ), + { + ### Save filtered data + rv$data_filtered <- data_filter() + + ### Save filtered data + ### without empty factor levels + rv$list$data <- data_filter() |> + REDCapCAST::fct_drop() |> + (\(.x){ + .x[!sapply(.x, is.character)] + })() + + ## This looks messy!! But it works as intended for now + + out <- gsub( + "filter", "dplyr::filter", + gsub( + "\\s{2,}", " ", + paste0( + capture.output(attr(rv$data_filtered, "code")), + collapse = " " + ) + ) + ) + + out <- strsplit(out, "%>%") |> + unlist() |> + (\(.x){ + paste(c("df <- df", .x[-1], "REDCapCAST::fct_drop()"), + collapse = "|> \n " + ) + })() + + rv$code <- append_list(data = out, list = rv$code, index = "filter") + } + ) + + ######### Data preview + + ### Overview + + data_summary_server( + id = "data_summary", + data = shiny::reactive({ + rv$data_filtered + }), + color.main = "#2A004E", + color.sec = "#C62300", + pagination = 10 + ) + + observeEvent(input$modal_browse, { + tryCatch( + { + show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal") + }, + error = function(err) { + showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err") + } + ) + }) + + visual_summary_server( + id = "visual_overview", + data_r = shiny::reactive({ + shiny::req(rv$data_filtered) + REDCapCAST::fct_drop(rv$data_filtered) + }), + palette.fun = FreesearchR_palette + ) + + observeEvent(input$modal_visual_overview, { + tryCatch( + { + modal_visual_summary( + id = "visual_overview", + footer = "Here is an overview of how your data is interpreted, and where data is missing. Use this information to consider if data is missing at random or if some observations are missing systematically wich may be caused by an observation bias.", + size = "xl" + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error showing missingness: ", err), type = "err") + } + ) + }) + + output$original_str <- renderPrint({ + str(rv$data_original) + }) + + output$modified_str <- renderPrint({ + str(as.data.frame(rv$data_filtered) |> + REDCapCAST::set_attr( + label = NULL, + attr = "code" + )) + }) + + ## Evaluation table/plots reset on data change + ## This does not work (!?) + shiny::observeEvent( + list( + rv$data_filtered + ), + { + shiny::req(rv$data_filtered) + + rv$list$table1 <- NULL + } + ) + + + ############################################################################## + ######### + ######### Code export + ######### + ############################################################################## + + ## This really should be collapsed to only one call, but I'll leave it for now + ## as a working example of dynamically defining outputs and rendering. + + # output$code_import <- shiny::renderPrint({ + # shiny::req(rv$code$import) + # cat(c("#Data import\n", rv$code$import)) + # }) + + output$code_import <- shiny::renderUI({ + shiny::req(rv$code$import) + prismCodeBlock(paste0("#Data import\n", rv$code$import)) + }) + + output$code_format <- shiny::renderUI({ + shiny::req(rv$code$format) + prismCodeBlock(paste0("#Data import formatting\n", rv$code$format)) + }) + + output$code_data <- shiny::renderUI({ + shiny::req(rv$code$modify) + # browser() + ## This will create three lines for each modification + # ls <- rv$code$modify + ## This will remove all non-unique entries + # ls <- rv$code$modify |> unique() + ## This will only remove all non-repeating entries + ls <- rv$code$modify[!is_identical_to_previous(rv$code$modify)] + + out <- ls |> + lapply(expression_string) |> + pipe_string() |> + expression_string(assign.str = "df <- df |>\n") + + prismCodeBlock(paste0("#Data modifications\n", out)) + }) + + output$code_variables <- shiny::renderUI({ + shiny::req(rv$code$variables) + out <- expression_string(rv$code$variables, assign.str = "df <- df |>\n") + prismCodeBlock(paste0("#Variables filter\n", out)) + }) + + output$code_filter <- shiny::renderUI({ + shiny::req(rv$code$filter) + prismCodeBlock(paste0("#Data filter\n", rv$code$filter)) + }) + + output$code_table1 <- shiny::renderUI({ + shiny::req(rv$code$table1) + prismCodeBlock(paste0("#Data characteristics table\n", rv$code$table1)) + }) + + + ## Just a note to self + ## This is a very rewarding couple of lines marking new insights to dynamically rendering code + shiny::observe({ + shiny::req(rv$regression) + rv$regression()$regression$models |> purrr::imap(\(.x, .i){ + output[[paste0("code_", tolower(.i))]] <- shiny::renderUI({ + prismCodeBlock(paste0(paste("#", .i, "regression model\n"), .x$code_table)) + }) + }) + }) + + + ############################################################################## + ######### + ######### Data analyses Inputs + ######### + ############################################################################## + + output$strat_var <- shiny::renderUI({ + columnSelectInput( + inputId = "strat_var", + selected = "none", + label = "Select variable to stratify baseline", + data = shiny::reactive(rv$data_filtered)(), + col_subset = c( + "none", + names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] + ) + ) + }) + + ############################################################################## + ######### + ######### Descriptive evaluations + ######### + ############################################################################## + + + output$data_info_nochar <- shiny::renderUI({ + shiny::req(rv$list$data) + data_description(rv$list$data, data_text = "The dataset without text variables") + }) + + shiny::observeEvent( + list( + input$act_eval + ), + { + shiny::req(input$strat_var) + shiny::req(rv$list$data) + + parameters <- list( + by.var = input$strat_var, + add.p = input$add_p == "yes", + add.overall = TRUE + ) + + shiny::withProgress(message = "Creating the table. Hold on for a moment..", { + rv$list$table1 <- rlang::exec(create_baseline, !!!append_list(rv$list$data, parameters, "data")) + }) + + rv$code$table1 <- glue::glue("FreesearchR::create_baseline(df,{list2str(parameters)})") + } + ) + + output$table1 <- gt::render_gt({ + if (!is.null(rv$list$table1)) { + rv$list$table1 |> + gtsummary::as_gt() |> + gt::tab_header(gt::md("**Table 1: Baseline Characteristics**")) + } else { + return(NULL) + } + }) + + output$outcome_var_cor <- shiny::renderUI({ + columnSelectInput( + inputId = "outcome_var_cor", + selected = "none", + data = rv$list$data, + label = "Select outcome variable", + col_subset = c( + "none", + colnames(rv$list$data) + ), + multiple = FALSE + ) + }) + + data_correlations_server( + id = "correlations", + data = shiny::reactive({ + shiny::req(rv$list$data) + out <- rv$list$data + if (!is.null(input$outcome_var_cor) && input$outcome_var_cor != "none") { + out <- out[!names(out) %in% input$outcome_var_cor] + } + out + }), + cutoff = shiny::reactive(input$cor_cutoff) + ) + + output$missings_var <- shiny::renderUI({ + columnSelectInput( + inputId = "missings_var", + label = "Select variable to stratify analysis", + data = shiny::reactive({ + shiny::req(rv$data_filtered) + rv$data_filtered[apply(rv$data_filtered, 2, anyNA)] + })() + ) + }) + + rv$missings <- data_missings_server( + id = "missingness", + data = shiny::reactive(rv$data_filtered), + variable = shiny::reactive(input$missings_var) + ) + + + ############################################################################## + ######### + ######### Data visuals + ######### + ############################################################################## + + pl <- data_visuals_server("visuals", data = shiny::reactive(rv$list$data)) + + ############################################################################## + ######### + ######### Regression model analyses + ######### + ############################################################################## + + rv$regression <- regression_server("regression", data = shiny::reactive(rv$list$data)) + + ############################################################################## + ######### + ######### Page navigation + ######### + ############################################################################## + + shiny::observeEvent(input$act_start, { + bslib::nav_select(id = "main_panel", selected = "Data") + }) + + ############################################################################## + ######### + ######### Reactivity + ######### + ############################################################################## + + output$uploaded <- shiny::reactive({ + if (is.null(rv$ds)) { + "no" + } else { + "yes" + } + }) + + shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE) + + output$ready <- shiny::reactive({ + if (is.null(rv$ready)) { + "no" + } else { + "yes" + } + }) + + shiny::outputOptions(output, "ready", suspendWhenHidden = FALSE) + + ############################################################################## + ######### + ######### Downloads + ######### + ############################################################################## + + # Could be rendered with other tables or should show progress + # Investigate quarto render problems + # On temp file handling: https://github.com/quarto-dev/quarto-cli/issues/3992 + output$report <- downloadHandler( + filename = shiny::reactive({ + paste0("report.", input$output_type) + }), + content = function(file, type = input$output_type) { + ## Notification is not progressing + ## Presumably due to missing + # Simplified for .rmd output attempt + format <- ifelse(type == "docx", "word_document", "odt_document") + + rv$list$regression <- rv$regression() + rv$list$missings <- rv$missings() + + shiny::withProgress(message = "Generating the report. Hold on for a moment..", { + tryCatch( + { + rv$list |> + write_rmd( + params.args = list( + regression.p = rv$list$regression$input$add_regression_p + ), + output_format = format, + input = file.path(getwd(), "www/report.rmd") + ) + }, + error = function(err) { + showNotification(paste0("We encountered the following error creating your report: ", err), type = "err") + } + ) + }) + file.rename(paste0("www/report.", type), file) + } + ) + + output$data_modified <- downloadHandler( + filename = shiny::reactive({ + paste0("modified_data.", input$data_type) + }), + content = function(file, type = input$data_type) { + if (type == "rds") { + readr::write_rds(rv$list$data, file = file) + } else if (type == "dta") { + haven::write_dta(as.data.frame(rv$list$data), path = file) + } else if (type == "csv") { + readr::write_csv(rv$list$data, file = file) + } + } + ) + + ############################################################################## + ######### + ######### Clearing the session on end + ######### + ############################################################################## + + session$onSessionEnded(function() { + cat("Session Ended\n") + files <- list.files("www/") + lapply(files[!files %in% files.to.keep], \(.x){ + unlink(paste0("www/", .x), recursive = FALSE) + print(paste(.x, "deleted")) + }) + }) +} + + +######## +#### Current file: /Users/au301842/FreesearchR/app/launch.R +######## + +shinyApp(ui, server) diff --git a/app_docker/www/FreesearchR-logo.png b/app_docker/www/FreesearchR-logo.png new file mode 100644 index 0000000000000000000000000000000000000000..e0f9f99ce3a8c12f5e079e7b0696b62e1bb28787 GIT binary patch literal 22712 zcmZ^~1z23ovMxNhLvVM`;O-KFI|O%!;Dfsb4el~X&=A~$ySoN=1`F;Emv8TL&p!Wo z?!V^g)wQbYt!mflNEIb%G-M)V004j{EAv_H-G6*{(TMQxZ;iD2t#=RBN?cJK0H}#W zc{YK2|E4gLQBwo}yy*adz;FMS4?F+>+}Hqszs3N7Kso?`?*wj96?&KbW}z)>si+9} z_)a4N;GnPoFz*!9`wsv`1o%hWI|Yz~BK~h$4T|BvWS{|na2o*Zf63^+`~N&L@9rPW zzkQfIsQ+lpgZ^*n$2^$-rlbFXF|4K-y?aPbGCD2*01Ea$4hoP7CIA4SM{K@myJ{;c z2$(tAvzVAWnp&`U+B^M&0tk5uyp#48t|k;DU8;c4^#1N$fB->`qB>)+;t{!u2N zqh{gaXy^7%v_yD0g#KmW|HJ%G{QeF2kGzJ1jjPE2h5Rq}|3+#5C;UHV{wMQ)1C&8F z7VjDPuXwTlSG4{o?|;bulR5zv8&3;6?awy$77i}|q=k={O^EgX8S=l85{`C`Aay4b zGYgS-L;r&O57z&d{+At{|JdQ;lpxm7(n*3_!m#869YJ71Ic+2`^15w3!a<$Qg!?&Jmeyk)%NOp(>IptxAl__sedmUGxt4Bkkimq%(M>B^9Wc6VW%cIjXG5))_F0#hI_Ckf##$0SW6v#;WT~jsnt`)hl|rj0*_DfzIM^B@^Z-$5i*f6hfG01 zL0BX>i+N1Q&wE@S(WtCTP!JAIK5Nr23o8ea3ZnKwjm4h!*&h8hA5HzV)WoltTA|Gh z)GQhS7af@&M!O-_jgeMv$zrj*I2H1?opi{hk`+9T4!sIP;xDMp7pKG%S6fSHX!>{o zuN|=72nVNe`{3g$9E!BxA+41TS>+o|vi@1Z%Kpz5m2G#+`Z)GMWu7mR-hFauL&iuL z$X!096yADq48I%)B}tq34FZj%FG6Haz3o1G1vmb3&oWQd8jT&t^)yL90?sJM3ZHz) za6RB76m>{OC0jJ2>gm;={G2}6KD7Gh_Psq)t%ZH$YZUi}N znd;`o5~wr4TKw9>5;;Sc2%n^VivYvq9;-If?8ejQ9G_?Z)kEfX>FcB}KmcP|WfB$u ztkkW5zKUr~%QyPhT?UP>buKV>XSE*inOzSMKmrxWJKahux^nJI?AvB_%B~Qfd++g= zAp!84cKM8}8|OM1uSf7f*4&A{kTtP|0mGRoF>)}MmDf;M5uJorDxa!X@%1<+wRu`e z6n$zXvRbL$UK+|YR@XJ^P{^psx>V@(xa@L%RC)7P=Qa5XLf0B)s7Ax-=g2{TR)LBx zigSBZ*8mjYHUcBT^LpBhN`eMj_a@@}0}?tc1Ewg3sFS%su#;eHc0Byo>1v!b4LJ*o z7>FZt8Z&K5ZB3q9p(*iF^L_Ze{Jz-7a{=u&XdcvP7(-8roKV+9jicWYI1@?T;W<=q z4+};X+dr^r`1la*BXCo(KKt;$w+2Za`gNWkf!RA2`;g%Rq`^=;{}Cb14;%gRWkzNi>f} z{}03f>zCe=rdSvWr;%o+DkdcMct3hdUEDw6Pio$29`5d7$|Ic^u9+FxIf7P z^>bQ+HN0r4viy^hCYnE;J}$U{x;CK@ZMd1-vqPGfr2fg+hBm<>^VG@a6@pPq{vjs7^2|`?TuGz#3^@qu-0GsU0m`AROOlA~QX& z5t;uboY!^G3a$Ip=SWnfB)SAGpw>LG@s=^YyWhGZbJLX zm>3fB^z_5%#L5{Y3dUZ|5!1rdmHhhW9D7sfx8ugCh_!X^5vdTs*HG(=ro4Z*rp|93 zb<2uz=`@op*H~n(L@6}DBzQq=CISgPUd8F5;i@wM3L%%tQP?dlnnYwS`TODhS5JjN z%U3=zN4jqC=7~I1uv`#Nz!nyvPoD-=kqrl|zEDX$Ryq`*E1?v&V1lWWgrv@P~0i8V+6thwu5u=3;o)CN?V}iPa_5E?%b#4^>Chh+7&H*VV)1+pyEf)l|z<_nE1pn-NJ@%W83p}$cH~A za*y-Ky%*^+6a%9l*}rKbvG^YcwOc?o&7&p5gF>DNRg$t+#2pY?vde%&NDhKsUP>ht zy!iK&Lx*ia*$=nypxuLOB-bbL3O`9n+$NvQHc=l^v(#_#fKu}`Sgk)F4t+e(Q@A@F zQz1w%kZ_NjL_^`040x%lp=YiIelbUue(<@yT#$FX)-X5kI%SpcT_LKVXKnd7EB9&^ z8%og690Uu!&(`$(N7dakC01IE+LZwMA>4z%z{Lhfr94lNv*02w$YW-k}eBh7^<*&E{Vrpqcg5c8p z?C!{ym?kn361y&Y1i|hKF?xC}^h$tME#`rZEqY-QoDofL*wdw!JMRkmITWRHc5lNcV(9^II)< z79^XnjFyU^0LB_(Eu|Mu%`POvV_{sYU{_ceaF^+-{C9?`T2O3X%XO8k2+*Bx+;Z1V z5BZ%{l?H<@U^p+PkKvw?>;5U%SKc87?0pR&8lmt{OH2-|x!8pAODzA4@EpKRLKa;sd)hDN^DTK83c1$FCi znD>0qF;Y3@31+8Y{h3-vhmpD!lBgH}7DGo0Qf&F2_1*#mWwugCKF8;p zY}QRxfQNPxeJbk{ExkgPYT#--*mZst4s;%5X5O{Pn209NOB5IH2(NyTYDBxQKuFaK z073Kc@qPY8`5SuL-ujB)FVnmxh;Yzal7O8b!;nXzJUY}9 zKg~YlW*wYCt1Ds8Im5Pm1D1<8g0VQR#<>XRi0S%G?q0nje!9e~)m7%XE+x5W&jr~N z!dZ2%z9Pf;)3ee&;X;Oddy_>u5YQl#&rXZya;gB7nONuLQAnM9{nYV%E6sm3 zBqSu(7TT)1G>w83jha1uoX-b_eyqVfB7;&_{Mn3h!iANB+a0SaLEV@QmjhPvG$JC1 z5{`o7PG&qzu-FLXl!K&K%Chor+TN~5%QV$`zodLVPBcpdx#t0ble>RXqY-q!zsMR#+pMS>G=HWcGp||d&QCnv#3fK30aY6>+4H;%;7W6y$XFv%7+Z>n0dYR=Mu1LB&KG0gthuDr@Jv%Laup41bO8iAs zZn_&jjg$aR{1`b{zm_!7AZuuC#FWTyP4^pIRCgn&v+p4dT$3j+ zIaX#CtVui$Xug0P6ib@kj)0j1vf84i0floDi3}7{=?zus;S*j_sVcX!* zULY7?J>Few?WHSE;b<`pS{|+3mja1rNMk4t$Z=0~W%ctm4Ujeq1^^)ycOpDXmy+1; zgY?VSi6=wGyw$eaU%F&|x7-Akafw*?yd}GO{x%gPJo#DIe^aeLyH|#NMG%F~3cbxFTrD)8&I~!cFm7HnuE)F9MQ^RzcNd6P%vU#(Y2jVu+q5# zel46FQU$$bzxAJTW%+^JqzU)SEcx#AB%z>#x+r+xw%gOpr|x&mvFXa4wh(&{w&I9Z ziH$4I3cNL)G#w^Gz*VIb3qn(=&qrrg#`-?3M+WjU=Ne)Ill@GermXhpzEe{Ez*^&% zqoSrBiv?zO1RGTO_3s~vj1KU5ddd;IbLx`Dl}ujTB(D?J{;2*$RXs$bRk8*4O(5|) z>z&+9C9b-VBS$#s=m>V{?8h9?Lhc4}_Hc6O&_mFKF9RVM&`2j3_X_e};u;Y)yBIUm7h9M>e$ zOe*9%8tmvk8iWaWXxv!5Q?375J3@gkud)2awFb8Dp%>Y)1ShcUj))ybUT${bSw- zRh{OO?H2kWJprYOHWJS{>*3`@rmgP9kZ}vpQ7h~`b`NY-Po`ry4wQnCfAi-K-vEJA zP5G*t!BNpFK6xeKi^WHaOw1-S-PZ4G-V^Y_yPDPS1H%1qH>2&dzG9%b#hcNI97%PDCF*T2QmLW^rd1KNt8ypAGDs z$Z#b3?XAsCDe;@auIo64XmqSMiKT7N*Vmn13jKgiO)dPed>&B>$)hxq5a{TCp2A*h z0@DMpmEAj?f)%?#hoj7qABiV;i5QJo=1;h7mKK^*B5 z3d}hRm1v9yw8Nye3ApxXKO6(?*w`%+p|s>LM`{zZY%^}aTt8yPZEymeZ|u_vW(#b= zeI95j$V@r1)h=m^$s*I2vn5rdnGFGHs@mj+op8veauOTP=y1#5pmm!yt8{=@9RcJ| z`HJ1%$A9LV_-{qzm5|f=nyh=rb-YrNY$Pou>B9@Eq~#wwTY;#=r0DAXVQ|B;yg634 zh6Oidq{5X)nwo}`SDN;T8l6s#H(Zg&0qLJ5u2}(_jV9A2?F5;3*r*6V}<4L zm<-Va(b!ErU9QH?bq(J;T3K?z#nQI&($az7Y9<^lj`_aaKGaOeAw?rhr1rx&tN1x$ zjl6v5(!9Cz4>myLpU~C=RW6tog-brs=RX!Z(6X3ON#&wmokb z;qE_0y>v8C{lsiaW;BN);_J`ndb7%L(TE-{H&RarzbLE|9gi@$N}QAyMbY83n;CCY zlT$_qH(o!^xWy-Ti-q|P91DdlF9I3S0qbsy(J5NplgP?effz~)4(Lm8l@%;-SSHj( z3qohGa9XHgf8dL0M*CHqir&tP!Oqi|iNE>uOlt%`F2k9P$fJuM1b%+l3t$~yefX~6 z&aBJDx^HKWbL^g5UqcQnd_(L^&~Si;R7#MD#f&!mM;(jWVoUigY21bo?Q)s{mr;r9 zfg+UTuB13n^Yr*wKjZDi?%0^fq0fxPU0bEy0Nyn&S-ap{U08~?m(GtrR&Yv_BPkg! z_@k?mKvWOzAzS5N(B&fqTyL2qS=6t|fY+j@3B z6WZM#tXt%<_8CuusEP=eMjTlxcL93`(MCxe%Z6LShKiM+o6By-8~mm6Z9-nN{TwH& zvqk%hX0+IuKA>5U^&z#I_mFz-3spepo?7`V*$!S-Rubz;*-B7lVk}QYDu$x)LCUvr z8XNM>zfS4xhk4@3q4JtT86`QJ#ak?5Rwx6(_KXaPm~`dO+)r-~(=+C=ESc?VVo>Kt>r$0HJnC+k z_JkGFN9U4jY47xe9X0hp_Ou|03=o*r#{2LumpSaoBuasq#^NgKWZJay?Ta6=w(V~rZRFa4NrGpZwJ8rXS z9AmW28tYG}A88xeEF~MX^eYx2e@WoY1Ul3?Fz!a;ptE1xF%QV|B4)W4gE+ZNnNBQA z`#2^loRRGwy-#IX0~oMnBe#v>bO2yzTpZj)JNMV&J7chA* zH!8PVayBnx3Q9lBeF_@K2^vL>#^{Y=@7@!J`>kpCSSZLZ0Az*M2?v5EL2P~kMqW&ljZ3{aZvp{>e6~ie4|BNR0h{mJ|jzBxzRj~B5HU=4hgX;9}>9= zsf+ARnMKW~07a||3ALOZ^-k$QwOs(=1x|;kt=$RfcFg@qVMOs!H!9H$oV540e z#xt7ZRa-J>mFl&xB%_7r>8U)s)y!*E$cvA5GU>*P%dBkA{J6qUppkG)c{IDJlKh1^ z={&EuuniTMe_tTB*eTTEk`8NvnqIFNTZyX$ti7TGxv+k4`PyzivxR6tm_YEm)|p~ zds=OSRwrx~n|2=G#W$^$=zWbD7?c~^`p$oaCo84-n^D_NAv&6XM;l$(8vM;Hn;mV1 z!nP7cgc_Q|L#IbWV{_e5^z`>wluS_KCz z^B{T#*eO2#gO%>|dovz5N5G{muHp4^v*>LJZ>#Q^iS=d~u(o>ZP~oTpDaez3zmtk1 zh;o}8mDycW_5fynDZStc7#4s|)&EBEf^4wvJ6lOLP z^F@l*PT#Ja#CZ``qU_Vuek-}UA1IFGl^sQv+qt%8q86Z8b8#t>z+%ywkfQ zg`U8Y*HCq4&M`Y6nyKmF4`ph|WFoF!n4Ah~%HJigm}Pr{Yi-j_GFT0?78glod0(D5 zbPis9h&a>t4wFbPR|g+_A`Xj=woBqT<3@K~z@NiQ?#SUy^`IRBdwsW9<}cwv%uH(R z*EhOo6oicLznS^)knGDtE^VwscAE=U2Upgp0~f*o$IsGk@)1aU0kaioR?gf%^ORp`21Hs@vOiStg#^?^{-O7g*Qr&MRN? z7n-mkuf(rZCE2d!s$xsIHbO-fxS)NQxKT5V)vp1^BDtUei_2$f4{iC!+63sA!|Rte zW;jnCIFHoKr}Y4-QAd}Yw2*-~Q0G43>C(b_8gGtQm!F{dy|Y^FruuL<+tS7CE8X|b zfWez`glAWN^AUbf>7WNl1DC6dpN{E>h>0`Oc@`@^NlSAf-EGx262UH+029-Mh-W6< z!mQ{7klJ_2E(CS6<9KDUHFEPI$-|fq-)?%^&%8YMl~4M#?er6;y8K~x;qAAq&Y^tX z(SiDmJ7WdHaRugNb(VArq>CClV!5PL$nX^GH5-@sv$wq?3BPyH`}A1x6U>;QeX^C! zJa7h$n9Gu=fLzWa24>Bdwv2789F8LAt-u(PS6&U5+%GLth>GKz(aQEbD6EcY_jiX zsUh|;8_7Rlp3*C!HWo(g9_O3Zn;1zuBc-4QeYZCvQVjB(OP2O{<`{z;NWAK`Oo8RN z#KcQ-3ZEX1pNwjX^-IBgHo@1&^ZgLN{>+<8&VePbx1Fkh)FW2GD%mlFX6qX2HJxz8 z+Uqg9=D)XTG?ts68Na!aG@OF5$p}|vYi;p{OVu5DvC8I~@#v%QQ|JnlW}-TRvt6lz zLZD#^iGL>-Zz+Ay)hc*CCZa5xFA9o{=Mujg2s(X?vco)3=-Vs5Ag_pkF;?v>sQ&r6 zxZ9U4-!VeyZba~M+w5#~DeXCT^=0y?&@ngXLr~gK=h0kzPcvC>?t=j|Go__f85Pw65B94gu&F2K2|Ku~salO& zQD>GUX&3e(Mw>9mLF0=#9}x#bjZ+muw6b06SCnRMb6?G4R9l63Top8O-9+ZDNp16|0x!ub`D#hD8Nt%t zr1#StP|kkqx_|a`-XgRm6{9G@*|nr$Z>6EW|SmW9pM5EG}kc z&atufw%7=9@q#&C(hk0R!itmkU+S;7q)uE!la$#d&tMg%%`9f)Cd72LZ(9!p!eM1z zCoC?v*WTFiq{`!;-^W@7Z)IqF;y^iK>mFUe5ycU&U1~<|v_GG+QigXjBjT(HihK!f zKu?ou(_dB;|8(ZV54i;Zf00=sl^|)4#W`6H5CPNg&FI@jjSIrxoT-0=&kAL0A^RAR zyHNREFsG7@3Rwp>X+QfHrpP&uWTCf_70}L&R(d6LZmC&leE@2E)q@TK?e41MVtjJY zlQKu#iN!WQqx*rl*#$9mU574e0y_$cvsehng(NnfMfL33&tDhOSrpg3GZLMqcP#G8 zTz(x^9=~oHt>J*u3==;~UIyLLh~#;cYAF^Xf-gdc*beQJzHv|3&nwl85+a$+Dz*CoEU$j(31q#k1eh5bnPWe+T+^9e(B%2n zt|Aopz4M2I+|4o*NUOyCrU(7Wzi??I!dEY`n!3?R^X@e-^;-&BO0DxvJtU~4C#pF? zxQL*tA4^vlk9_pN1Q)0C&VFTcW6*?x4@}hSmvA5T4;YG5ncwEj7wdeg`GsL9Q+EiM z*QzIRNN3I9YA4uXLuTA!|1$Xv6b%h*h^DDIxw_FHho9lG>e)NQ5Q=>04gC>Duonir z62$yL{>Urb;=$SI;&O>r!jpn*LV&RbHFWf2(1@bb_qAE*+OEO(=IB%N^Kt2BS1;v{ zYmTxQPo7VEk}H#z$J$i2=ma?wvIYhgJ)|BP`X*+kc@1a$u=Tl&w6sOP3Ch)j6`%|O z_C73yWoilxTR8GO0B!~kbSbX;43DnYJR5Xe56w({zg|fYfJk0|lttj?-pn}Pn?{qf zrjTXkGjS&BwLv4(gVdwRh^0S25pJ7wqI29CgRf87lhw2;e{tmMZ2{LF^VfL7#?(o? zv2Cczv-wSbPL{vvtk-2)mbjl1uhxrdHmCIjXzArf(iv-Uul}Mqt9*$YNOwb{JN^Li zc-v=ezE~bb)vVvLmC__a8@ZoL5OF8UuoW^Nzvdkf(3I&g1ePpD4I`R2{>Pz*+>AaCzi_J@!+2wlD?7wUK(NnJd?91a!Nf zqGOZ7b38FgxO>bEbCXc*E`WJ$ky4%J)Rm2?Ds8|2!uYw9f~G+QvI+bsnqoB`xw5&F z^@pbZP5wN3PMzxr^4<=ZkC7V1Z?-)_L#VyJN&%-EAfG#y1G6_R%?U95!o>3j@on>K zRq2t7B=lr6wr_mieNc2pw;&F(7E^rdCtB&@kT_whgCA;u+^n`hIuaX#X=*vV61emZ zhTPIwPhN5FjMsJg%Lyyd;lCT@v;o}F7piy(<{n=F)gJI7;geB&vu4i@9-^1cXVpAKtP5=S!qjYF`AkT}%GZD~ITprC zM-&Jy{TU>v1qte)d0n*Q<%RLwNU~Knucv_AVZsuU@JsHwerutM8(DHAE)M59?$Dzl z6IuMNB^h09rhbn`qWgiM*zrY1j=_SsV$F2Z=qVVj;;#ChK%M#_MbxI3-l2e==V$7OCw;Ri6ttSx=ul zC2$GAqy}gifMT5z-<0d{M)1$Z65%#Fzwb~t!<410dOmedcfOQObJ^-N*nOdxc7|Ma zD!;V8AGTUSez~c^P3vV3G}>AGLL~-KI=sbFOFDeYq-Gx=g=Ypb7k|x*@Ve|jyj&}W zYn{^AS^m@5A%UYQbhF20KWU|Z^KAk!cM}i60F00Pbtmu%dbIrWb&MeT;>2E>6d<^& z%fmAIC6-+*v+)=85OsI?3|`fzw~CV0x1rvH9yJ(qiLQO?^X=dA8S8$PzZ zEQ)Q^FUXanKi7-IS1h!Br$3l83%^(eW2k;1ge4q&=|SwTZ4dFL6U$|jXKB9$JscHP zwMJS^e#ga-lp3vN!g~2E;Ir;I(Ke0jfZD_pCts3HP3Qp`dhVD1VeYd)08m{bi25UQ z+VtRk_oPe519s(4Sz#;Zg;@)&loDK~AQfti3g-xV6>g=?@E{07;N5syv9Fits_m4Z zA5CLj2hPp=w8XK`4fdm+IQxWMxUbEf6`r|+4mA-GTP2>Db~mFmjh27a7ly1|%m@&z zH-<0mg2~HpV;K`3l0)?HS;0X-z4mBw)<`51HRK6J34*Ygp!D1h8g)a@8_ENXSP+n* zfoZ&mHGj2Yw&~B^4YZ9?JG?HDg!FIahA-8Rk}c9TL2vS z?a?ELTgGP^JupxgZf-~yZ@-aCUya!KIm7Eq7N2q0Mf5+|cW3#^<=3fUg$Y>^;p`*a zD)S6t5~OC`E@Vw>ldyQay0qv=UEEi)oV3zmAxU7i%-|BHFRzRWKjuvmUvZBs9_+u} zUnnCIQQR5${U(MWtM~)a86A4%Xqa8bpK2eo5v@C9u`bw>M5-$ZnO8k~^NoZzy~Yvd z$(3c*?_+4=tjfnAc`$ZXTAxymU z4x0RY-;+l9GE@;ENdR@rZO$J&-p13z`Q)87GYR$7ca?>>SV6JZGHJRqt$NkdKI|xX zJ`M$Ao>FEVln!6%{Dkk?91Zkx*@_&=nPy=^lW|7IbgsszL40_zaC_pi62K-baUfu} zc*e1ZKzBV-=&lE2;AiMQ30_$o%yyAHXp2++dP}F>Odt05*PsTTOOYKD-?bLHk$$UO zhKDk%&3@fRtnvJyl(N@q=1mcE{qW;P{z{IZy2a5x6AotVZnO3{E&bTy)*;$h1rG^v zfkk37qK&EOxf5-aHi0AYUasq$1^iXs2KHUuZ3*=EwVY|u9{}nN!;2zZFI&X}%eT5x zoK(ltt>smhhs^!~im|4Q%Hop=1x_UaXTD!~BTR#?e~R#jb_4j8D_gEVH6Q1@?7ptN zp^Mv8d=vj-rOO197Ar?6tY6u_O*JRsniB8tBRJE4rII=Afg!lvhCCB4*K7yd2z}p< z)ieGR@5-h_!pA}z>IXb8op{=TqlU}|BaqbR=70s?$d?b=J*kY$4`yYeFk?jiL}+JI zoSF9pI@&|`Vm<)2%rr8Zx7X2tE!vQ_s`DmDHXYm{f^Pdr(@asK%i-^r7UVS%)qoqt zrMq|m-kn7r^dulRkfIwGWAxIt4Y(l7)*Le=$Z6TUq;@W8T)kX8s%2!J_5I+JA;Zax zjVt_E8Hp&We-Kj9ECXxFsAJiWTJ>Pw#KrK}-=ME~YfV9gbPvMWy5r+2pldu~;3qh# z`T=|Dw%344fHg6wLe zPc9=|1ZSPlWfe_GRwE;SY!zu}5VK4B_{irvbDy84SDdUeRv*q=K^wiwy)1$YkkFk6 z+M?Y9Gu99SkFwRfsia~fyN~Sa#`;25>t`)*>|eei9h9}Bq4~8~bjJ8PA;zJNXPx;o z@rvG%9sA^4%oV~E0{MhUHwHTyvBiB~Qf8ezQj*QSZL%(`Sq_{mofX%AYWeUy*)C+z zLgFRD^GSP>VfA6t%fm^9iHk)x1Yrcb>RDN{YVANS1l!{GD3!wR4EJ&7#K#o{S%Nv` z)QTmBUF)ucWS%`}QH3;DbC|(Oz~HIP&pwW6P_16sthb%l997oqX2N1qwOdqTJJJBVmwlF;JU&_A8=t_<>SHU6mUNO1FiT`G~8 zIVi17un;GOtf`@v6w$b)7KygAR(0HnUMcy!%*_@WDl~3Tw||*2qt*=!<%JQ){)-Ev z(ph~dM8|yt%1T~=w1nyKusPo-3jw8i<68}DQfL~VFgg2TpN{-MkWCsh-w)}&5kj}y zf|t{2q9dyf8K8Y!s}VOX1+#JL6pu(5@sTApa=+IKFzDI*!CvAw$@MNO|LK@n^ot84 zK;XqJLJh8N>?zmph1zaXov5$BmhBeE+AKD2a(}#ALKd&*sF0>-bg#{lDYQ&*Sm-d+ zmAP2eywQ5TIy-jEs#|I!nWwQz-^nbQPNm?>kN?WRf3+PF(~TN_?r%`9J8!K2$4P}T z&8ow*`+7rGG)AHsV72OZeyCL)C8+6dn9IB)n$1WL<|MrRdl9C2);4xIHb{B-&`6*E z=6Fa)fU#5HwqzTp|6Nw1L{{kmmjCkD7E(JK%P}&lQA!MX7(DIIDu6r&yeN`&zM&1T zs8C^uytb{n&;Ci($YfS#ZF`Irx)`9J;pEZ(^b~5gXjA>Xb2?ZABr0PK&;#bSyO!zH zfm23(v6IRk$@d~BtzC3wYj-0EEi;&FN9*fo_0p z#dr9oS!}C(cxo>fRdi8ATc}?okQ>D!Uehu3--Q3c=u9&2xIZ&NB0eOZp=Jzp>gCqT zxLF-E_MtO!wekMd8b%{bP_^HEnn4C;k~2{Zro?TeGaH%iba;CJ03O+3pT`Rj!~{X7(ctW&=h2gZv;VeDS;Vt7 znoLBS%oho0G4Ud6XrLULy4whyDG#*o**Co;nc`+LH7 zJ@&b@6qn?cd&%BuRw=U#kuw+Bvj7?*gD*%BkBdwp9dNq_jV&GDqvGvmOpZ%tl?-_S zYQE-*7^V*mJ~YK#5G)+LNw89(%~X84US~dTW`fIDHc2bxpT9}8jU|-W;U9!;)X0DB zT73=Twb`ZwJ=`=7p~Q94w@aB$gpK;=N;qm$syTGrIX~Rrlqj^DzF3d8F$m+FU*m3G z-|)X+$(ed8NlzPuKWwwDt*n}@e+XKzOdt<^`5=XZT*0yL&AXsV!!*dpCmLOBDnjOO z9XUV>BQtN1*N)Ao>1_oSJ-<7RItD88M>Q zNnuU~I-IiPdiVHj)-c=eVtWRwG+0LYh+TJ8wYSoFvDat7h80`VjTyUN?{s@OZjRKf zzI<#QEbMSQJX>#P?M1lB)mP)6Eud17aRz9y}vPj zSB{;CD%)vi9_IoMo_>^3-~LU6An)9RL;}W?wq;cwjFX@MrVHm@iHIT^2;q5bZjB#G z-}+hx7=_OX^&T|18(lBYR7BLFS?bY4@tfE3_tDn< z7|gun*s!^pEF%!2m+LX4lJPo&F=MYy_1Lh&rqNOW!O`i$*JXtJ|k26c_sL3@V?n&}Xg@_T)HY`6S@cG{e37_AD26YSG?L&~jF`8SZ~w^qACyHgsJtl*q1_n!G&FR5dec;$ zF&}rdRj;e93QPAN9nAdIcTD+g@4No?CJ@|&rzrcA7*Q;^-s_92z4`lzPRkAQ>Ja(l zUeuIpl4$lXylah&Yu>hUH~i)Qv*6(=ZimYT)3E`w|VpBP9+V&{x0uqfOH4Q(P|qryhZk z?ip6zO@o;^raMDWzXrg=O^XwHsa4hf+qi1b*6O1qz~Fbh?;R&1KKX!Rv8z#AnfHlm zI$h111I4&7ZD_hAnoEsxb{qfBpn$Lo4w;$F=xc0U=h;yk{{=hK4&|oo++!~<{vB>7 zZk%xJ8ZXvuQ(OB60mI3ecaBe7*`dYq&5OZ?J(HtvfJeAhPP+lNuWN4@I+sYx5}?yU zokg6q#?XiTBSZ0Z3tuycK~T%8e||)9BW?Ei(R&^5E(88*icm@~Zq18yK+!5|mbQ#|v^r^S(Wz-H|E) z*N|%D2iN!rE27vv>w;Xf=PhmP3KOYYH!n9X5H%LUBZNMs_b3UzbN>+t=aT-x_##w& zQdEW`4OfnU57nwV)GXG=L9-bG!Ox)NuBg7&_@XtTWHi~3f10>R)+T;l)7|oTi4y;d z+b3}iGc_%0fTDnnIXGc_)bbMjy}It{1=-)pQcs4wxK#4U~0r^tC50bhuY;Vhzrgmrz&hlD9vZk@1m+CHSLBOt){fdz< z#BBYYN zPXVjjVGuq{wgc^^X27-&Trt3rH;|rpzk7>D)4F2S-Dsy=*U)GnWXNM;Z+%vJu}4o5U50=yB;W&)PgY^ zLG|OD0==K5Urr%u>?bTSI&h&?b%2{bNl7~#x-bx$s#%$p|8C~Hd2c>RuT7v!U7IQ) zpNjV_o_b_6R&2Ij4V90kJ6wQmsVxyowJ;AK2?Fot&z*zMv!<5Kh$OL%8&8vECZ+;L zR1_6XFbD&KIu7%4LXz6k_i$z+t0b5?dGoc)HpU3eIcHr=t>eFLC~UvN1$%SR@e$G&hmwSASt&;oh$2-m|%G~^lz8(|V6<)E&joyTwbq#omK ze>n2>>aV|DC~Ty&AqA0{_7q}Xj?A(SFKoQo_3%g%nGpEs;2yL|XD-^9TZcXY7c7mp zBN_}ih^G<9>Q~y#>-3%12zzAJT}iUl_GgWyVE8&Dg7(zJnjaTc!BK(=BPLzlHb3S% z1_MzXR`uU+dtHtF71T`_Pu7j@o~5@cY#_$abcc@K_bqnjrB{ZXDL-Q)hn@`3yCeI_+4=N$?U4fN&qkR^J)5yTg?KeI#g?G<%?{)=^TfwuSjALLX^A z_y{doEq!mIh>nMX#x)`qn;Q;&px=In}9Q z$@l9~3JaEI-j#N&@Z+W-MMUs2T-!SBH7c=uHbm|aLbKW}9Xy1CM>mpAMaHhE$r1ON zxnY1e1`Nl@&@uHO0>V(DTPR0)KrHIX#tM_9BH&0oc0!`t{*JKZ559x9JE5arXT#yy z1M;v?wQq+)&B+-f>G9n)SU+u(?&te;AM8!oM$%(DoJ-`W-S3iFw6&bKp9i1jxIde8 zkARswM``z;XWQ+#Z7e;|s*aVxF5%D>d4ZZ-r|vGj%=p8_{kF95xQP?je|n+K_qNe0 zJ6ej|7NROTG`(AuRaBh+=u4|S2xJoD_hKJ+Y|lQm!tjr7qd>qzru%zBR*RBAUO8^} z(p}S194bBp;YQfH1+~~@YI-uesGc@20fd7b9OufFXz22DSAAv;^Ez1594`J3an>K> zYDe?F$RY6d?nSbk7IjQ4QVrpLc<%yukhr!6S#Ujbc(>fD#D#V)+HT?br25)cM)UWX zfKU|{TDntK8({C4+%!vBeViu#`j=z4{&0lhd2UWf!wM^J>jzE;$3p?JyGNw#EPHV% zO6aGGgK?J(YrHD;75N3Aess}OWTM>u zW>B}?p-8)9ihI!=tq`&4GLdl@6}BCQXCgNv9AqPh{Dn*3XEne`VN8l+)475Ni8uv1 z4DCGE2h=C%K`fCzK-*}RTLmsCm6Y3+kaob3p@Y(AhDsC6oQIciwc{7?S2=h7Rb`o zn=BFD1#(t;E~=o19T<8}p9hsx`?@0y?D@6>oab6z1-o^PrMMvJY|6-!kAGV)vC%saj`-2;mlMlF%>Q;eY%-Fz3u&76PDp!N+ycGbo6;J4IQ4-Febo0@WcGs zhtL$@6xRuS`gV|O!$yBw9Tt7Wmg67&vI0YZmdH+;(XKt51<*u9G#HvEpZo1l4 z@>XmI=-#N}+-nmG5P+R-ZuUxdL86t^n6-HUeCU_v>GmNj~;H zkAraN24ILnB{+9bG>7aWNLx9A`Guth8})C6NML zeWt^M9GyNzWP)AC;q|>e>1#d|+@2g=fv%udpJ1=3s4z-N>MCYoP5!0p3ef)!Hj)p^ z%(?I@=VZu~(=UGM#Klbg?4xLUsdeX}G0a`Mt&TiH$oieQS&LF z6)!8d9^@%wd-?>qreON(7;=lpDy@sw7ht87B{JpE;RfsqaK^15S3q+SN#5t7+}sXy zitz+HeI9MyhqvcPfz9;woWQn&ogh|V+lSC9z|E@xc8c`BFI|hqZi6Hwgcy)hV@{~Y zft#(24KhH4pp@aWy--r(NFCR zqmg=%UBRVbBG?15b+dw<_mz{Y_^w=Cfv!FQub}bd_yiQ4a&GmRKFjP0cBbnIbb^?N z9q7ucg)|HIFSWshL8)T|$$8#pv8 z7ANqZngZTHPH~-Upf?BPb|Mm9RM6#@)k+M+`SXq*A>FWcy&uGIf?C&pC%6^lJm*2h zoN{#qx7}BO(^sx;_Z#E`Kqt8EhXPzduD)mEL$O^!?hEK<+G%mAd_Q}I%wLm_E&GBD zCnw0Mw@8T#mu0iQlz-jzpxkxK-^}8V%!_A(WY4p=a|h_&sN&pfG6fXm+31rW?-JKj z#`KajXxEz}t~Ztt!5#!Fx^nKuifxe2KVpas?AIOBKP}Epfa^hU+kwt=)xImp32dHw z0^JUHZ~5^Ba!HoRY|by21k5j|G(&NnAnzL+ zCM#xtA?IKAcX{#2`Zh5WDyWptn)tlq4ZT)8w=zZh`x*`Ldew>==Y|KnP-J(bei zWU84z4$zxPFekW00q(fMjSy+^Hubz~%n({XfUvoJ@}|<0_BEW6nU6K+`Xq(R5u^J_ zpB`PzW{U*8a&zV63Uc}s;}z`MZzpFbsO>;kuzTi70Z*XuTsgS{oc(eF+w)M4PH-E5 z!<>~|oRfHdUARsbK~#^0E`l0$+ON|rm@DxlVQH%6;N*8;i|$)*y2jeW4rw#5Ep-mi zTS~b<@q5ZyXz_OHMgJ$WzgpDjIC)!<%Jka-gsqquQ&&$ej;dMMD$3;gCwx? z$9n8E0j8tTPz>zX{cwNtlJDh-=U$PkFPnzES@Ygo19Hai0G(8DT$3r#5aibbJFotPz#7zuHu=|4(bBbmjHf{_I?Z{PtZr_UMTwjON2!wBpABdMk+cXM5ES^3%Y{XMHu_fV?%@_2$qJxHF3_ z5F7+N6?L@#E&<>}ql4wpfn8-lpRQ&ojsPd%72Fm#C+MwvyzdL>_B;`2dML=f0lf}f zdmF@eF2&5}6w!;IO<%hyTNb2dNd|VQ35pCb>$`ECHz>^NX zM0e7FT-pwFitpSWi94H8L@%$XHZ#uBvbM-CYqF%Q0DIPBfsF{5uW|`3&Ld}EJOFv_ z8Wk)n(NE_Z@ee)myj*(GxyCq%@pFe2mc6Z<1N63{lj)!^hk z+g)5&t``fAm$9`1t2Gya%DJ!wO_9NUV==~#MJh1#MzHgsb{<%gLINK5yC#Opke+eU zt6QAJc8_HyKaoUOGfZ7UE0@%EQj zq^PJ^PP_U}$zAl7NUwusU}B^c0PvODw!5dkvj0x~bQ#Cr%dyWo;)#T4p8_+|ZV6GC zC=w~5A;FmAZS~;;j4eFh(0;nBL?|4&FF{K>)L}Ok?t4~+i6xbl)v^Wat7qpI%lh0B z$t%Q?PDm#p9HKZja-gGV&eshGhY~Rk%V<^CUb6l1Gq0*jnexjbL0hIYHG2CK(bVl^5*2==yF6M?i?5pm88xDDf{=_;uuWcfZvZ&2<~y$819>9hPQ}L*D#k6QOH~o2JE$d zu{AahFlwPF9)idi5A(7E@h}Yno8mbem|!#%+=j{@Vb*M*CVid+3_404yY?J8_Lw8h zvRW)J0nRwui;FW2bq>{~btfN~i2$ra=&5ZBwntks=}mlHS0v4rua>|zo8r!ITj z0y#iIj!UO~Wjo;KEm$n?fAppN_nGMkkquOjlzt=Pjcs@(0AB$U+FJCfiD5dXMeMQ> zpbxmY@4HVBSi|!S?Se_$;?^dVd5eG!1?T3rNX%O*rI7SlCcwlKE|AMFI8BZ?{2+|? zN1J<|`L|+f-(Lsl?MvVNE_OS}j|C@RK4Z1?1;{g-ISZ}11t-kdr*(63bjwqh?+S8z zyqx$v}OLNU%nHKPzCzwSq0b?C5Kvd zf*SpFy5xy+#nkaKZuD>&I(UHeP3|p`5#iP|{O(PFYbG3^D<%Hqz5Rj@Etl8>v>M_78jRDMrJlPMqDSkdHJ$oW4fen%#`mI ztQW~xiVzUD8+F`HYKV+Kx}Ws#-AxAd?;|~Xbd!F_XZLPhB_=u=X?`25=g$GUof?0_a|Jo)lXDi@;vZLnlegb2G$pZu+&zR=utQQ;zT?ua zTQlP{Y+Lwt;I{=3+d96sC}U%B?Ak0f7TS6ChoXRjoU65-deQZJ59C{+sa{#%C+GCn zwszjYO|a6bzuPp~k4GSli~j!N9FD%fe5p3hr_Lwe1TFPpXIw2A^U}b{yY9hpa)|4& zC=-Hw8OO={w5U(s#$@@!M&|(i5Bq6-7fd-hK|c6|%cW|0E-c;>+g-cP9J$R}bD;d9 zxW0;xq~=VkW4NlP`DrSd(Xo>)497z5C=;ym6d-6UB9ce2oQiZFrhr8t09cQosRvODVS>yk{5JjpB{s z`jB{-YFA_Vr9C08V?H^x>lD{rAlE$Y2ju%hWzhlpAL?_~7e-A;Ra|GEyf6CX)UNLd zkasatO(Cw=baadB4kxewK70Di8D87d6yF2s)r;#^pPb@)@=$=hoyBz)%{@+@1(4Tv zl(q9|yN*R89PRoZ`0~D!a5%be+U%E4>>wXT?K=D95ZANY8RXQibGMNMO!?fzg%>zM z#RYPQlkfei*1wiKXGeu;F&MgrTgP47C4mq*5jVWLO}Gt|}AOCzZ5x?Az)i0gay z!?!RsM;X^b!tL$X6zC--Wm1A2NG?6;NUVKUhQ4`*%v_u*HB~hdi-{yPuAMvED!<08 z72>+pCkH1_ecS1iw-s^QF&>AbweYb905woQ0ObKDh((J^jsF zlb*xTTSL9Q{H}8K>gpOfb=tKO5gjW@T@$e(V2$`;lR$LhC2e!Md@^%^L}1@AF7UuT z$C~5ZAUEr-WBU~8B&&aURR%aiXw4zxUJvU4eXoCl)@4A4*Oo3{CBqMxCjWQWIpFlx zHoxTh{#bvU8yEcV+gTEc9Ynb&IJXgMic^pq#T(aM?-(elzr1FaWY%<>5|0yR?^D1L z-S_@CXjKk4yhhGGZ0I2Dw|%ob_U`u*6v$mgELVrEf4P&$8Iuo^k}7TijFo1ZAjUTU zIX67?4{|`RMBNX42k86ZNAs2CbI&?OZaC#2dHb7R&BlHz+7s+a-MYx>0DEcmcGEC4 z26hFx>62%pPwoeh&v@10Pl$gulvW{vMQrM4jDUKDyyo@ zcsrj51O!NWMwWc=%`Axy4>abh-r{zfwQ|G5I)7O+=MCwP{mC71-5a&`k9!VB-#@<7 zZgZ(x_z-B}AA8_dNdS=NEL&y(dp>z-2U$7S0l6>Q?yvV9 zW!(Py<(iOhRi4$rTJGgH-j%;z`kY*L<5Y=413)7ij<^5x%N!{z+$woxHD<#@it7$1 zZvt`mvmg%8_p=Yy-0Tv}6xHcw{x(<6zv)3qN{Ey3!v`8gT}DQxy!rGOA`tOc{_=_g z^5znFKMC&ueLwk7t;r_)<#g<$=jIp4E8y<8{PznP(Jx6h6qHEm+;mxqb=MtE-Wn?J z+wVF+-?zU{o90eMc}B`Dljkj1A_av-a?DW^CAoJGXPmrEsl9JS<^X-)`X23`8#{Nm zC&v5a_>TKyQovbw;*a@VeU?hWY$mqYz^(UvzUVyIuPN~VZXoM|LWuKusJzVjsoE#@NIp^c-3+Ad^~PNKvp5v_)Dc zk#MXka?_GDPTEj4qD20uYNJxMO=KuiNhO3^sUIpWsnNCaAFV1!4v7)wrti(|tY^nF zd%JcLA+;lo-prf#e(yJLXLr_fYeIa)Pu8v_AVcJ>WrWlaLP8<4pH0a7pvwk{wcyhKGj(yP6x0L1e_bZ%X-^@;D#1wY2Q;%u?^bapib&UtUYT^-BsnG+bq0 zRiDlEn?_H8o|>x>xBQU<+LHE`tvw(x&mu1zi{<2H|8mpn^(%^siqgAUi_%-Gi_*iD zl^Jc@x9-eaka`Vm%qsfcf9(aM6!fzxUigbK*?jy-zPmk^Ah~=<}F9TUXDHK z1p{rH)|WScka@Z3-=&m#;;iC!to^y#O*Xmm%K+9TUHKg#{&IdHvOxvya>?nQhKn2SV(=ZpI|+OJ<#@f|SWwoDqw z55ODTbot2-Un>`ECZKP zVSw8(d2C<%8l|zRY^dFAt!2Y7+`I!aE^tlnIN?fTuK0rw=Gx*vFOc*f2}jk%=LW-H zkeaMqXWXf)wH5b0hVS&g$?XN1kbf{cs>c?`VAycF)o*M{sX-?M1%wXn4p3YA^ZIO4s* zczmI@)@yFG{GU5@cpc#Kd7(sGH}@f!*$R(=Qdd}<>WYdioq@aba z_prIY@%d@rbuOH+gn>dZ}P`jGuGcH%pYT5o_NK*bH*H#l9K)b zdROI{Lx=EhexBbM{7n#^A6J-yk<3jPnr@aBF8USpcnl^ttgAXVZJ}>kAHW1;tw%w_S+r`Iqvtl z^V8lodEvYh6^0G(&u-prIhKtNSE}S!_qRU_dTZ^NZI!90WB7q2UsP18+Qp0V-vmA4 zqmSF-ivP~W&6fdC=I$8hP{)_}bDs_wMzTvn@%j3FfAL~3a6^B&%Dh>QV4dprA|9G? zfsUKC!+e&MoYOAbAWGN1ZNq{rdHJ4w$5}v>2Z?%>R4+{djMBDf}6M z+!F0CZuukTy=~hz79=8a^TrK4i{o?uIFY?PF8(bEW3I2Aj5C|Q^!FO(W>%$U&59p@ zBg;X0GPye|5RXpmjKSyQ*E42xb$L3Amcyka&l?3DzmBucg^a7}!@Zmadd{7Gt>=C}y5>DedQ?l+J}QSFwQK|M8nIy@b!$M9*c!bJ_+AQWo7c(WrcXIfShozkn_ve2Fj_{ZFS8cALOE1!=CPs z2YGV;=O$zT9^w>NrNQOBzq5X@*Uu!J02(-+N=OhT2~K4(2|wt7M5`+xFK1CY3UV|^ z>9|42c(8A(5aguMH(45v%eo*)+Ba^1{DAh28gNR9l7hTV`>xOdLZYp5GZ}_B5O>^&OU7doaFExe z(Mw_=r^3DdsW3`PCk?ov&3RFCp7i6 zXq><^GtLF2o8lPP4S;O(O!q!~7iPG78rBud<5C~@B^3v^{3SSBm*wK@+0)wdDbrf! zFx%LCkL42K83!9Hb%%4%#pXDes~P2q`r6%~=l(hz-~72s>w69Xmp2n})W#14l0M||*DNo`Z@^Rq{jts{bu~4epv3q#-jbm* zK0NUGb#vrjAAYpej3L3Yu9ll%tc(xiI=$d(HEC(Vf~F7bRIGz&Zg?BZ-F2B z(ojjkE7Ne=7JrYn48WP?FFzw4c5cUF#jhzTc>^n0v)CYU%uV4KvMt@Yc@^$2PKEpO zn6gaB0S-Dpf&l0z7ur(4xK#*r;t-2>pnF=T(_bWc`FeeNss=VrLJa11N*nNdJFWBr*%h>g{$IL5D7 zQt>BnX7S;fp!>Uu&QDAGvm9h~sPv@iD-Vf%$M|6AIDYWS-J8r9%G}@>kaqeWN{fGV zf8@A{jq^u4RYAROjQD(H0>-u1&h%yZHQOAI>zEuKp7{=FoIbG}u}h0`_kwgPh@s<% zdRr{94@te_0PKWoxjo+0#DC9MT?f2ws%rUb8l1Og*sji;pN9Jb@>OxL8z=6u*fq-+ zmnSxzw#ds}_y_2@%GtEnbnEpOUtDPV)7JX>jngCUTOGTa*_ttNbZf!}_}+V$@XV3t z+m(+EK+#DK`0;xRaoxp2i_5OnK3vtmW6Q%A%L*6X6k;;F-0TIfE1>42YT2~9R*nOG z8?OQ5xb1t_IR*S5a87}Z0*+d!Zxl`$;OK*7jniHOPAMo2UZHo+N29k##-g{cjYY4H zU5oaOjYJ0~Mxt301Eax-k^eV*{*5ZI)QLl_`+HF|0}`$+&tHG z-^e3|Se*Lum@0Ro4VAu~^-15xing2s*WtSpZ}TyfqE2jc8`QC?`G!vP5!<4_*p_X? zzStIhcpIf`BlaEhCwxO;;VHh25b=0C)Uhi4b}riz{O#4%Z?5oLsqQyY;Wsynr_`V> ze=AenKdKx_@ZP(4Mw}WXBxQ_{0eDNh^;bgP9fS%y!aGpk{XW!Narw6rLPo%53~VRC I2hT(Q3)77O+DL zu6zIdX02IWQ&mqrRXx3CPxthWP*IXWK_o;3002c!R!R*3Kz~IL01x}O(R2E4@wb7o z6ju}nfa*A;XJhc+YjRUrHAMjMq6Gj*FaSLMRY48_z?BUEj*I|6APoTU9J79@3jH+% zn`_BgC@KPse`R<848jDU|4N{LSU`lpKhgf-lLry~A6X4V|6e{(01##k!2Fkw&foT* zL-z0a59Z%3bROtG5%Zw_w>JpLgZ_{F4=icYUH)%_;3%u@3;;-2|C}HoBMTn@poXnA zv|O|l6$DHjKC>8`IhdHUczkyJ2L%Xu2>ca4o4Xj3dwjODcNXvvru>(Oz+d?vH7h0g zzg%2wg(Hu5&eO%(;y+CG&i_@`-vU|xv9PkUu(AH%VCEjy{}0$dmVd+kRoB1i zg#HO8psi-^>|p2mPg)|p976wM`2Q&Xli$Aq|MCB5Z|x%Tzajra{XbD!|FQpv=D#cd zCqUWB+Wc=v{wpu`|4Qq>>;9YnKh+7SSbLb;X-QdsHn(^Frxs3rE+N+ctL1+pB^~S> zoYWnSP0dCA68#JE-&Ft8`(HfT|4*L(X8A9q5bHm8`@h}&e-EvHY5$Hb5kw)@|1(ZS z5JTNHZ2&+FkdqSE@Bkf?z!_opx!rjYQd5Xw%F-Y(z`zFp`CzDEgCciuQZWQRFi%yb z<0S}3RSZTW$)P}&6B3#C{W=yR>j0XrJoa~R+jkQCy4-Uo`GCltQevIN{8YA|No+3OoU>>Ht6r$6zqHXWMM%o@@`x367}m~S2jHaIW?$E z6#`9TF;*_w*Vox)PU*gT7e>@e4|Y z0m1A#~%^w-1&f8Y41;pxOL1Xj^z7gBNl`Mb}P$uHl~lxAeEUB}3(`K^SE=tpwDN>D_F z!*szZ#`}RZm?AZVdcFgUYXmVQfYAl|72;lWg!@r~0*G>NclKDPE0R$7+tM>IFZ zG)9cfMoee!WfppY7#k%CXSNS!82->|Ep7Jl^;Nm({&Rkz3U+4z*u=TZjDs3CDO$im3=_!G(0Ku}d#r2u6m^I%0&42|f%y0xSInT`4 zR<_SO3b3BscWS8?z1nZx-pYzRclC`_O1VPo^tK~=?Wq$vCqs_E=K#cS6bD_Vol7LA zn;fd`lWEEu8U9oF< zdX&P4VAIZa=pxtjh_4MLCY>j%~{4mvE4|=*piLu>SFa1jCnl0Ki%4k z3t)RzO=o?uwotj)jPYQnrJ8=u{mjjpkidwseYTQ1QcVk~yqS1D~;=$l0u$3Y1-m!iateMg4WFRhFK2 z@?k~ahsBU*8ZsHjO-YhGsYiLO{{2+CpY|v5+x_UR_npCYuq9U>1rL$wqe`qfqU`$s zIBe0Yin|`&x)c7Wi|;ph*b*=rKcqq|QO=)U3Cq8sK#V*bLrERNu@PxzePkMR~8WFNG^4~Tk zB86iAm|n!*cBe+`R4tp!Xl?UFo=jq=*RWx8?Dfz}aZq2AB;Q}Uhia|8e+SPWW=VsVas|Dtdiy%!T*8!n zE;zqm@E0Hir;|0j`=s;ri|edB)_6zIw++xZUMB@lEN7>l|15$tB*0zSV}v)=_C1WV zhyY1h7|2sy^)&yvH7klQfK2@zh`(Nb_s7Nc=WlAIz7*;+*(*M`kD_=R%;S>NlKsso zC-$%-A%yAdTT;})u*j&$`dctGCiYCB?A76y@MhTHJy~*87&Oh3r%!5X1rq{yC$+bt zwIwgi*pdB22+n9VtT`k&ApAUjwa9|Ab!`?@b%$h;}<%&gJ>U5t+f}KH#!B zZ0@!Y+7=xa2j~3f@}qiL65&mfz}Y;UQuf^5J{}?3>5_h`vD4A^0D6^=UX&54PBvTy zbYlB=bY|R;%>F%>*ma{6wrtGk1S4d&5v;M9U#y-U!{s02ZXLYk=%J0NpRxT$62tCC(g~t)3W-dgA1XM&o3k=nI1&tH@oq+!i}JC4*5OnPZ@w z5^Y^sJX)SP529L^T(QhMBYccv>RQGaUUfmry@4d2&#zY7%1tmz);_4?(n6Ul)3nlAig!Rc* zyVH8FrH}KW0Z|nQNuwVvv0Z?jLzMFX`K<>;(TnsR$g6{#`1<)llONDvcXNc0wutH% zdF{KCw4pITT9qQB)AG zWI^re)Gt87yyuXS*TMH&sQhdZG8F0P63k}PR^ckT`0+NWy2TCJ3#}g)2n@^h7cMrs zf@m0o5ozaDc6G{9-^F>FzP})E(n@K3+v#wn6XEYL9GQ)cGR6Gr$O3MdLCD^qN@Vj^ zV>AUqQx%50pU-$?ts8fCc|~I|H}csKMRx~d7>wKu)4A8rN@r^HVdozkH@b7ouz7}H zl#uF$_dc+ML?TtDde|Ko((OePKWHJ&iruj~iBt4q@JFxmz~ASyH_;=Syd(8IdH`j*9Y-|9 zg_ieeuH3abJ>~Kdi`g2~PC-NGzr2QJEA}g93m3>m@pvbQdNAZW8&*)bBzNO$jWf0; zu9*lmrozE#8W8;Y*k>UTK-;_a~<>bbpjGE=FgY3RA*1 z>GI1o%QmnXE2v3ojqYO@fAx!fGW~N-w>RyHqSa~#6OYJ37P*{1Dr4Io6X}p9<#qo> zA{+ZB&4@%yC8aN{l$fiC>(9F*QM;R`4;@v)CHAn{2Mqt9QseTJ8DO!IxAtfjBxHusJqAr7x#m3|p zPMP~zRQ_;@Z}V1p{d9@u#~ApRC|m?piNnYIvxu=xbAR$N-r=zr%#p%`D+FRdl5y5G ze?Nd!b&#|Z-VX+AuL@q1wK4KB3BY+qq)uvE@v>5&rR5c}nG^wc&DDxaOuElE z4PK6Mppn!zkObnwqa+MmlIm3PcHR*3b~4h&j4^Fk@O!H$M9+htcSPJ51rzNP^0nXj zT$yY5$?C*DX^7Qgb~}u9$IZJ~&;K~Hu6xs4TNz_J*+g)09N##Jwr%wW zoC=Gf40W|j_Qx_v8}dN))j9SHMrCZZ71>f{x*ykLg+STBsuXP3t=ZO zH<>@C{w4S|A{;qRR(=?*@kKq2V=Q#z{4gp%ZX%7dQdOSF*)o58CXBIKU+7c!tV0q> z)8CmSfk=K@c;7CrXyO@THk1Ydg{IKku;3vw)-M!D;B9_?{uqB=&|vs0*&dE2tMOT# zcDiKsUbUE({kAT8frLX;7=~PR?z4lf!k^n95w%B{#NSyq+{9|#6DL(8@Q?u+;r`?6 zwH{iX4GSI-+=-oK`2v6yzVKdqqJwX!Lt1f~MWcrn_k5CNPZDdba0cPCynYN3i8snv zuQ3A>u{lK*xwQEjVt?*A^l9>yp>N}d#`YdLFy#5uk2yDQXxv&jBnb)3{g>+*kWdRK zXw*LkHTii#;sGw!`Sv^26n_HLe!a_HIKSSU77>6Q7&> zTyJR8M)K+9$M>dQ{|!*=b7wdCm4?wWBe;ex|Emuc*0Ry+QoSw}xX_$R<;O~+#w)uz zDV)}2GFuX~eQp~rnMI~2yn$p)OHjXpcFpd7Pkz$x6e!If9wQ;T1rTlaRKJFHPnUw( z>~oN+5ga3Iq7MFTjGXNKMQx1sCKUQ!O*x3BBlRm3?y#uQ@%A=_t&m*5-)`8Fc*UlB z&gaR(xfI?t?Htro>eXFoi<+d?GDs^^CfFOz5cx#(ygDShJ8qO@(#t~}Y-~Vl7sU&3 zbh93pVi7i*A4fl6Krz<%XaLGlQB^9hex`JaA$WyjtmO=iA^Fr55L;;aF zV5D6<8$W{wV|4_x@`_aHeYuViQV!#Jm+$;OFu^-(FOj=;56KqnQcpc-g6bI!r|BV1 zP$^w&s!;bz@w^{zn4R}Kn7yHP2ZW=tn3Md;*Z1&N{JfLMKBZomwo&BAppHIGbO+$l zq}!rISzcBksf$@*imkKs5c7SZsoCH7vfjyjcovXvqJyxg7SOqZ-d?~jAo67(3hr(h|>5 zV#`0tfyft#KMdQi{b2R_!8IriQR|LPLw7j&l}kC-e&gPK=N5B?BsfOtd}%T6Lzn`4 zC5{d}s>hbGfMscF?>0nlra6DT!I*8d`nH~2!iX8Ejz==hqvj!xNOz+C-b(iWbCysc zaJLk#&_!az*09THKxME!Kbk(Vp<#?^wp)@EZyEsA3s3y;WTG`8g7!JkGAp$aZa716 z478%FHsqbrSRx|qP-ni@-A1fk0<06j$(Jge%-V7nhSfheyz5Zwb07cSO=w_vK0d8l zr>FhEK(li%f{0E9Tw;hgZhYrH|2erlFoQ~Ev_^S4doWaM8p0vFc9%@|#uNe-tR*QU z6s_)a#qBsr-OHnGqSueK?pPWg`U#IoM?`^s!1Zns4?VuXsRZDL`t?))sU5yZJQpA! zsgip=D5gwcm$U77dB7KKRycLQ>=WvS@K-WhYteC>B6D;K{XsmvXsk!_e%cJyRY-k0 ze&-+x#SW|e;3+WZU!ewBzlIhH&><1H`wct9uk4V?iyu%hG-xf=e|`XyMhX@klzA6r%IMv{jL$VzSBLeMO)Y62Ab4avruCWFN>9P z%}I|6JX1C7!J?9T1xC#q?``@@X=GDOsD zp&Q$69 zky>l*#~w0l8)dWU8IE_O4<~FJNW%~Q07Jt~jL`YV50dVmdi<-w#)Iw9$tdawyYC2; zm6c)fei0DRJO?dmrCx+bTM*Gm6aEQ-Im_hs>-4-=L2&6C(kcRPSkktR6dLGSAL{M$ zE8%jqKTkEPvQFe)t!6uiZ9Aes#0`Td-h&SYwiKkPGUKyE-pZ{I~_xO0!g+Rt_wa{{QK9wjimLps_R%bo)%vsBavrD%r zenED`z$a<0j-342y%%fHXLGLloIpF!e%r+*(eZpRrrMOQ1mS%Y4|zktk*3s)Ztve!4{;fqsM81} zyn{(N=Bys}1n~=~sUJxuEiw`WEYvA9J zWrrwfU;({(V)!Ht$yH8aq&~dy3zBgq6ZJEr_pv01SN3R*hEg%0#B2+T(S^alcjo?R z!+Cn&S{H?Cy;986-xL`ApGPT6UP*XHn7g(qfN+0l~W1l%U*R5dEKJ572?f%j1&{Azd~EF zu+cXnS_#*|95jLt^(*Oqzb#CX>JK-L05~cx2(FOng5{7@nY4Sq`R|kzp9;O}aA*E2 z|E{ZY`5I(uJ2w=n3Tp!QgN>T)MI9L}Z^Z=L3Kn{hx{fL@FF=FPbRON*VukJa#H2K& z97%B|)anyU*I>n4YuHiEtmKrHVoCP!hcQxYrsL3iGTFc1Lpi?f)U(*JdsAL_=XLN>)r)&;J+F2dA=z5oT-!9$?-!mjip=W^8w` z(P|~eqk)obsC)9yPnq{LeoM_~@k*BCjsoIYxwn$Z-W+T zdl+%@B~6^3_MTrjwg`Xp277M}coui~bT zP33eErfRrS?H&QEA!!3K^C24x2kWgbxWvFpvT5jz!pY=fnZN-dI%q&hT%d|ur-lp? z62Q6r2{YTsl5tvN*w1YG+6Ba4l5ENlp&U>A(mSdYf2a>WBaEcYs4AGKsK&}Y-ba*5 zL=pQf4>17oU_eqGf3VccpYc4c7Oe-vx4s8E>qv?{L7%Q{+SH95)T4fZ^hkz#Pi(8x zo>p}y8*<|l;?_d#1T%KbY`r`0eGSL7dvUOY+Rm)|9V%60ZYZkBcTg=}7R?WZt)$HK z8%U~vp@(+dyj_u=1We#dpI}G`IE@)&8)w9lgI?W=(>fchhW7uiwdK77@VUUFbaF_c z6&i$T8aC~cRSO%{O_w-9Gb3DR#lHRsPWrIO-b=L^qQ*i52AKG0+9~pEjs)P5qYnR* z(DGjr7voI$Fj9Xh$7kT~QF@|rak{g;rkE{Gh5dv&!5)e`kDGFwRg%9{&ei%n>)D(F zUCz-^1sgX0{-VR^txm(E7p^@Uy;n~$W+k8Ac#WXO6bZ{KKO$=g0u@{%KE#@ZEU2cu-x8^}g{7RASTq6xt>$wHtf0xn=t zP`9bGZL<7N@|dsI4KOJj$F-A#I&WTOY}HD^b5C&QE1{h4WJB^az27btIVYNStH>#o z_WW@}OMRbjslFU&(XXYtPQ3sonCiD}&#w!c@wkB>kg+gi&7oCz`~zgoFUamz2DB6P zR93^wY2MBAwP27ZuWYDp4}J#}?lJZ^O~~M*Bgu1au+%Luy1vx5115k@-6fl;L0^q8ut28VVqwibr6SXC;@7R3q`H;$&0`58E<9X< zw!ZYZjc={(j#R9L#@o0%RT!m<@EyrWhp5(E1H~dQPJAn-CQWGC(0~)8Zn9h!+>G=7(OQN zke7ukkE_wiR&TuKORk5%?w@>3oa@=um*ghg$;yfrGc-~n(6r~X&-6_jghvQcQ*zR& zq{|mV9{)}bQ%of@4*Pz9XBot{#HN_G+gNKV{FBljeOYR?GIqD?Te_!?YrZ(_0zqC?BPzYsZIAw z#fuWOv$@XSc=9+#rfQ{MV391h6qxKiRI`G1+{^ziAIBtYo##~4lKEa=_(tKeE`@e% zcJGg4PRcTDZTGN_`97?s;t4so=1)1w?7;FK*!>_Vpb$Nrtac6}&*k0he%9lOC-gpF z{LxDixaK3Z7eENk*>oO>D!jNv6M7u>&Yj1rVpZP6jEonlxdx~WQNC|1_qWG*nThk~ zCGBF-qn5C)A&>by)f#NmDQELK9aF1__-!F2$$RV{s%O{D9iCl=N9_mAE?u1Lg^gaB2-3Oy^~heE-pyN z^%u~gCx1GxTSImC#y1gPhSyChg=jt21Kq#i^?gcEMry*V@+OT95vD(smPz#>-Fx`A z`1#J1>~-)nSA00jh5jRzM+EZ4Fkowm*(ZBtiHkz5bUk^QL>?py!Wx#L4X{30LUD!u zGcO9TZJAK8!(u*a!>`r|-Vo2H8|^3EBg7|TU_c28Jq-Pf|2uJ)Y7S}A=*p8)(?DBl zbi9aEq41|Os{+!Kzx$v7XCMz+3%k)@mfYDmdB;96P4F|#XPa?4sN9%nkk2d>E)C(z$&lh2^IW2c^PK_dz+5)>*&M$rin>Fm^UsXRjx@qb1Q~52*Jj|phP!IWw!VFKVtXW&?o+J^@e!@bw!m2~q$>SEz?oEyMNnhUj zKD~0=q-0`rKKqt}i61RyV$qq>rU}oosV5^<=7ic7ECDQ@puPhTKBC`D{F3;WTqpw; zUKk~Gw76KqXxSbEr>$TySv(cGQ|G8`ldP$ls1#PlB=nYKI2BA#@E&M$VZxvIWa00U z@`pkHGaJ9H`?wmDKYgVNZPE&)aCIBsW? zXP8MVY8S7zhOL(HrF>PHjq1g0wF7qf-@>GXAvw^nmS*&5>4O~~hX8Up7$1anw_{%x6L z2RhLeC>r=byzhc%svNdd{prr<;NfNDcwjym$gaOn9S$p@x zT=>0xPbiAZnbZ(URxk|JcC`m(-08Zl`_ea{>N%ctErleQL{-P_;GP6s7A*pU#jK84 zFB+;-6dmMeC&El~u`1J#Jg^#{el+Jpy+;S<-7BWwwHiJ0u61rvdkChEJWnx=WA|zi zb_|u`vr*j$BQqPxXqLJCD&LIJ!q1=tD8F$#z^I=uctP}@+-BldvD%}Ob+i$Y4HG&7 z8+ZNqd}gM2ixSa=rUDawW~hsw;qO<{Cm6O<&hKwe%+uZmqvPY62SPO5P>!!eKd9^A zlnoDIDT8W46;VnMWuXDt1Qpi%To(Nn6X(92&BKT)oy0F$`VrQYBHGP0NWHt5)YpK= z{p*VRxAb;4UTj?64QN|fAQb*V&MqPbQ`9;g+a0%^A~1+-q|227fCZ8h6eEz<=bAs@ zq5Gf}vz@VABj{owT<~Q^dwr97YH&aatF&@xb^(XO6^$l|Azk|I#OK?pFBhMUjEorv z{|+$sg)7{eXkcRcmGcEw$X1rAIUsQw$a|{fZ}Nt_^`OKG2a-Z4WT8!&7>x+xG8SHZ zgxpfnHT@2qu+eSIEo9eEbqTq?r=l!HIvH2&)q<739naZVOTM+(xqfFR(=^kuLC)lg zXoKIyWKG2phb<&q8Y#nb;37&}s%QpklLX#rmmq*_&eNI|QL~#?a6w>Ou{0_`-y|4L zI**IXfwp;5wRP_A_LM1>YGOr+#s8}SC$gXr?i!z?he7LZiQmGOOX{B~iQwP4Hl%M#ieid9@^C=%L<640VS8Q1V)6QNJ2aGJ0o}G!wPV%X6ONF?W z@wy~Ne|(P!`+-Ww;z7q*YXakjR)al4M6Z+@0kGF7+Bop$ZK5n`x8O`0^bzR7p*|0J z&$}dSVb#HD0!f}}A_aF2CK8sLSB5F^*phf-*NY9Eg|Q-Vu!RNF`(P9(Kx!QQk;=8o zhjXbzmU9pSqD&P9H)m{#E%lYjN&JGiu34L$N$wCj#T@q>NS@w>fXLCGn=B3KJCEqP zZ^EvPP`c2d!c@oz)JzMENHB1R(4C{1E*I3)^JJWMI@TEXkoS<}F~4!(D?~f$u!%GfB1Z;Jwt2IfZ~|8eFp7VBR{ZF?J)12A zPg#i4J2M%9m{BOBjxc{S?5O1CK4d^o;>QMO(whJt7~8;rRBA16J_VUWyd>?LM3jEa zaFWPSWCK6d5;BBuVr1kGc5c9L`{WEVFD}`dD@zt?#SE?=5%DUROe8xnU+SCM@c1X7 z3Iwv?6p-~=qi{9K_U1ngBqW=jC#*btDurnpLPBF+KMs|aGk)r9SSyk0M!Qx^%TMMibHogI}MdN6Y974wP8So&JQC( z;)4s>Lwk9aX$tFaW0IM67g)qVMgoVZ@z@$lgID(AEVcU6StGo)<0rpPZ*S1{WuVKI zQ9@(6YY^Uf?_SQiOp?v&QWy7lZRdeDKusQxDjv7H{x%YowD`aug;2S1*;OJ_uOfq9 zB7O}NMEYQBIuqKiMFk9wZ+2Iol5fR*e8yJtd%TGy0i#CpGDrLvuLD-2G~pKi^1JJq z%6qLBF*7I`WI%_EN{6bTzk_q72fzL1Runpu(sA;OdYj)&!O}*k44AKiH&}|2n$Fn( zak8|lG|mbO(TC>1@uQV`I_lre9-mD7J4H*B?ZUhhyHtX`tQ6t2sIJ{h>+ST!!pXF4 zq1XAM8>nD`Vav3Rx7Qxav!7%I=WBV52jN|CG%zTlw?l>fGTEndr6Mdi$&xtvkl*}C zlTZ*!jH8DK56-_kKXqnkoV$mAQ2;zvS(omzTBGL2o!HClrL0`DS`S01#%iF`a1eRY zo84+a@NwoRB62Z_<#wh;qeuYttqWd^`vkQv&@rkbJI55hmYDb(pj)^fb}XhuJUn=5 zY6JMRI#xuZ7mnoY(OV6EC-zNL*SSnj9dWbG`Nt9D8VC^mz^QWk~RfS9xF zg$<22DK_E+U1uMhdB6_S8GJmnble&gKmeiD6gFnVWO9Rfbv`xgjwX=Agpneam=}R2 zM<)qr*Ed3z5X-YvhLl9hZYVfP%*;?w*ohQMZTy`!!Vc-ZCU;)pt-lx!isCuErxcN1 z9FiB^=Uj)Ke9<(FrFI z7~<=dI-091`; z2SXJ7Ede0@McKEy>Ehj{MOc`BRsW@nh(4gH`7RtqyR=WFR ziw_-#I%ntEX`X$BXS!2@2#rY-g#6{vwS~{or6X#RyWhjZQ&-($5jLi2>9|@Q@0SFr ztU_Vs$JHP%8rU#oh>kvhg?T-P!=$8M2P@bxAI_9@emkFyo>%>-8lf_RrXK=DpGIDi zb(h<6x2>egcW@Hlxfaxv_a59hL1s10m9nnV-}ji57gAVx^2ZtVLak;V=eHSGXFNp@ z@$ysV-R15`grFmuqTRD`C5SxIn<_3Q^pdNJIcUzr7=>^2Z4>{kDin`ZDyGfu2AV%$ zL>*}8rVLD|_co-WagI^Ifx|M=*OD@cEs)3eIjR>~t@pfY>9%B1{Q=pc%7O_(u z^Oh7BXL)Tv6nz8);v_ygvbiA$;2yIBgJLyrxvGC=5Te5BUokVo2jn*9e=zT2F z2*&}E+QEU`vW?-igLY;7GTYx?_b1z08WLlew7~q=YLw^3pFq&%fX0G|;f&~cl~lT> z9Z&bhTUs^M-FxXvzAD5r0dZuAfx~yt>q&xks;a;zVR#@6jcgvM=Rx$o-^6AuAOFyz z5E#NDub^IKj72A>Qd!WeC>y*7Yackw0zEy- zVfNZIk2RTwGBdtoBt(G1*cN29vNKuAVl2>Pbih_!2BGgWyk`)pd5|RM8G1RITh8xt zJ(}HvIefEn7l#L zdB$BFo}0Z;`t*6A8S7b-<*OLj^$=vmJ%_t_dwPB z&mbj<;3^%*)$aRi7h{l0G0;NXOaNAiSCn~e$GLsvBbSPR)g|a0%ujVigcJ%ul13FTeL_TGc*QYx>6e}uy4BwUm+rOM?3Q+sI z$GQr}3F6pOAdas}1B7T6Tn>ZEAPbK7zVA}#odinqfZ@c89nnumV`&1n1)oKIGDCHH zk-RrPfXPdyE}apUxE!hrb-l`F;@J=4=Nf7?c0XjJsjkHL29x~Nzz{6atMh)ZXvt1I z3uvMe+d*4f#6M;Od=NSuo|ASh z9hMucM;8E9SSaDC>$iH9X@%LTN=0F6;NJ19?wRe2wIB(j=|;yPC`0v)p;r}1qW)9{ zC26L$ODt`yERVEDl1x@kbXO2{eExH|`+0b**;GH{b76p5kr|4kru37&e(K*>lN})+ z)KEICCqPf&K=J*eOHG79Rc>An-|`7aO3Lae5Y(v;iK>YI==jVYf^t}4K~MLc7%^{U zBczq93-(S#k}RF$AtJ2A2X1&>yXx6)Qq*1w? zJ5KhzgSD4sMgx)t!Ej`+WnVR?JRGe`zNXiE1R*LXk&*lRxJA%@VYq^Yeb8T-g=>q9!~4Ww1Ka zV|jhRWj~6q#woZ)Uk5?aD)#kzax)#HvJ6Dcd7$&UnrJ!VwVN#LSzmCV-Zyxl3#1Mq zL~5wzI7HzaSQnxgpu`Jv;79RDf4}ia=YD)Ov_B%^^%k{DR`7?_<}sqD=#vWUcQO@h zhq?EuKY&#yJGY`XSjgB!m~|Su!u%Zwq5)GWksXE*X17BQ2J`t*Mqk_(6<#Ff`uzMD zrPOkf#V{#D6apX6^@G4lFbUa(>5D-2c&&ws+0(3&ucY7VBa*^$duaXNcVrJH90VH_ zg0-N%?+8o5JB~G96^1Vck|T?64?hM@;?FPmQyx<#cX{!zBO!!cq9VEc z4lD7|NmucN!!9odZ%@_Izq$!U*U+kLfOA_7niZ6xN2Qg!RP%>rduVc#rs*1DrwQFN zIMNZc<3ixL9C}82R>jmd?e97z+%G8AwjYsHY)sJHLZc1bU(Cwf53WN5!lWE7sZoIZhv=%*xz9akEnq={Pg?;7I zELrMRP%+}{8rN@@JMD{pKP^0wDScIjHeO%T3vi@)%%{(MG%J2c&lHPOfRCd2BGkXYBJMKi!^XnB)%pXbag+!~}ZbTQ3uQDODqq(=#s zML}^WjQqedwN1@0 zT7R~g$kslWW7EH@Q_-Lp9~hvEHg4_K@*@R=utM6uOPL#+uKKg?+8UDiT|jZe6j9gu zl#jLN$i#8G;X95*?|Sc-07%^JxVNy7PA6&Tk-4A#)dL&V6CLMEaKa)6*GDCRmjxUf zY=+5+XjQ&d4R4{b4$HcdWJAHO3`j4uIjAU6OMgI}8VXamgl-Phrr^jwmamFIPj|A+ zz{W^d8$+H-sc|VIDytLXB9=jbq^6%M)!o3HZJo*WeYI#T*}U)iuL)5JO0oA+K7O`e z&l+HYa4re)b%T(21;u4#6(+mjTly(7et!nA5idgFDhO*nRj31jW@*C|d42KHO6s22 zlb(-kgfW3FiM~W-jIB+B_k{(D>S~%&yq}*Qq7uWhm+QA}VbGUC$q@@H;)Y7?A@T{6 za^+V+X3&<0wB^0KbUWcM=OUQP<^Z5+`gbNN+eK?NppAyj+oDT69~H082L{)X8Yqab z={Mmw_!Xq^mU;h~=eEgtTs;?uezRL3jtw?!$KNarG=kc7M{IgW6fWWScb9)JP>X=o zuGP^g0JrrEnZMiTf+Eo2Q;|&~2wl(p+t~Z}h-tszd1RA7c~w(Ay5}GGn~1=FKRh=* zue8{$8=E>4_V;xRdEI~Zv41=e6}OK}X?>vl_CeqG;vp6i!un^;YP7%Z+e~V5>ht(lsHS&` z6=v_n6WyBRz$0!H>O4$LmvN((#mqq8f~5#QEU1q#7u!lO>%RFZ>^Q4MmW=%oEx5O^ z>3SsC<$eDZ+IfCV7b&zD;!2V$=724~7Msb(OL|T4dnP91#5?G^1Q~O>upn($9cbHN zKPq-Lu{1b@kCQ~ETw7las$2MzQDEEKGJO+2N|Md{8)jf-84kv0+nfiJH|-FvBR-&# zz2Ldu_xW;`7Y0jB+I0`Pa{H9$(Asgc3L=Zqnq>@)dKoKBZ7r}?|6b_Jx{~|#_kV~% z3{K~>qvsQEnVz^DUk07J?wpK_g|a!>z+l3IaD)I9!g3@uWiD`*lqZ&lzdB0UDZZ8~ z9S*axbS`GnDt_C3$=Hlo8W}hUtz+r~wy+H~4%5%CXvRy2(EjcqNOdByf2#J6Ef&2d zPRA1+zdF{CCR8!o%r6bU0W*uh$DTRbA5$@NIZL{~k+9#xQUC&hAb0tbiK?>n~rH?lD-!k{wIwbB~$4m22SqfB__==wdI` zE`vV@f>#&}(O{zM8B#b0(~CuXh5kVEvJ2OLgb&%43OJtubA zj#&w=Yu&2jD#RtIvEOO61VAqQHHlF4a8-23CA>Zle>!xU-qVU@Le8-tbml`2HH4RF z$VevJmIWOh0=M@zynn2?2sP`PL&dQkjj*<7N5G;Fi$N-o5UEQ!#LqKCAN)R%6cu~X zcM+93vEP@~<>;wJrBr!COuOu%(Md@9W|bp*bfDde#61}~A-dlwv0!JHj!wkL&!HnG zqTbc|@cImmAP{2@QP-D$uyu&;(_;%sqI$lc$Yd>-|GcmdM^!GSZcV&wH2rl@Iw*h( z980#u-Q?a;jfQY0h0tg&V(-hERom=5z^dqU6@vo*vsIrJ>GM~KGF8hGuGl^l7!t%= ze86O=px}3R677X%<_4CPp0k?ANV|ca`i?vt6zMYoSZ2P3tUmH6Py_cz~6ysR|W=k z#Cn0%?mu`jqY11PCf3Y?4{g-g+4 zCmh*l6a?YU(p)>tG=CHl3gUFDD|D*&FdSwc!N$Sff%`FsinhLJ3&0yOX7m2kg9u3x zkbgf*c=&D1Z8M9&0Oox7(x(nIF7hbl@V(aO4fa3XfITP4WCdVo0$}#bzr~Y0IZqT~ zY!}xB>0;xSeU_F(bl+0QLkJxPFiM*JN~*X)AA6yQG$R-X*eS+1XZhPBP!CyCtQ}yb zwxc3l*oY>HSh&nInFR+4{)u<9MuN0%EB__v^zDL zy3CemY0}@HNXJhM?li&^X2?oCbE^Nkbhilg;AoSb%I%lZzmJ(K35|z>ve4>#hlj2L z@76W!e}wCg@M=3>9s$^)id(Wwj}eY3PNv5mMta?mDhO(xRP-WXoIK)FbjB0+?!YZv z($NLeSL9-Z--udYdDOfWU-F}yQmhQCnyUgfRAxUYC&StvRo+D2E|4PHD_93Z5G>_~ zZNkKZP{q@_huOSq=9SafJ{u4X#wQ&*_W#TTu>%9FdNK}t87`@jY>^Ul6j{IHdvZsq zwlZsE%~C<=FtC&A9n%*Tz@|Q0 zhXl;BIH9_9tPD-$}8+DB;K_XzJ)<;%m{4K!*@0lVb8q+bF=V+G8_d z+4x z2)~F$fS8C_OQmP^-Gaez*m^oZc)slH>}uz$)r>leNU*HcHX{oj45?B6+g~=x001jv zNklL#Y*{2L6` zzTs1q@z((Zz_(etb&D?S(xuIQEJLH!Sp~>wC?Zot_wLvjws7G`0cF4@zp4ZZ@HGqH z6c{sd(E9-)u~&@xLg){aZf*ef7vb8F3#az>oHu*sD1s&wTnXq_R*|F<^z*Ljb?ALK79G2;*JW2*&Ic7w3 z1UxOx)f{005ZN=qiVi5y0CS8_eDmXeQO%AE@LAI}t7te%aAL`VBO4qHs1Ipk9{7;lX>&hnmb3NXsl#vvCvW@OBV zeZFtwQRLvPNoK6!tN_?TOwF7+`e&csL&lEgaknl%&O#$Q;UEb9dH8rUgI*se%;p&qvioWYcywsbV_mvue1xE?)G851UOZCJDU2%+nS+09AJ~29qYslW-O?eU z&%FTcVPUj(NAqmWBBsEEPa@&VG z3y4W!kc6x%KcdYch@E;dkTptCJocZuT&q!w&YK}Ur`BkV7)y5X+r@Lbn&HRZc<1vN z0VcC-3BO%ABDfs8cFiZIQTuI3H&#J*$+AX6lhFBk?alW;B3=W0E18~1krAmOkTVJ+ zhbzg9MngX4OROC}FD0-r0Rr1U)w%pDbY+vZZ%WBZeq5dupq);Qq5`k>?A`B8jaOiv zzNkz*KPUZ2eWAel)|}6mS!-FjJU1zh}!&4KAMAL;AfqlfkNi10w;` zCiF~Ty#|MpVq4Pr|IVc+w1(KW?a#2JFog{C-oJ|m7kh0#g~K%CGFF04^5NPkvdxj(7Kglc~2p*ev36{I8G-J#c7cg;1d-Ij7MYWHXZ;V zPWU`#(!9svo&y7JoyQ_-I?Rh+!Vc10^VVJeE6@<-!Ifo#&}{0Axg7wH>uR+)-2h`t zXd4of{0Yzj_X2b3Kp3=k?fNiF1yun-l1=~q-Omjg)RSxy;^B#t{Hz9O1`s#W^TN^J zlza(8Kpxfo_b*sr?hKU7I8_$mXl)6xJ2e3)If)R%`G3zKU*V8Z(pgn1k4xiy z8PA2?iMb|iyDtz56`?p3Jg13?9JlN7&}@M=qP!)AN`rgtbFod+*6lh^rpx0`$?=y| z$w1Ii!I=ru$Nv-)8?ny>zr?H!z*%1^m>HOV`)0#m_8u6BdC0-JDL{v{CQN)}RcvzW z<8Z<-bo*#fxFrjCS`jWS`E%#`$&c~vXOu5VWmYm^OU?*kH7#1Xq3+?o_6@)!3I%EZ zmz>(-sgfZZu`to~qqe4ou=)5YRHj6~ERs3pEn(2)CudCo=&)u$phZ|c-c#@jjybw^ z{V!pN8LdI_-W3CdA7Xd(0FWhw*At)091Zt5Dm69(M0k9_T1YSIBAbUm+8U9Go4(z; zyEc4>f+2ZLNb;5b524SXhbK%&sMT5>>VZ{Vfc6wg6WO52{v8KTg&Tf$4_G72kM{%MWilO(Mk0uJ>^t%)0ZCV3bcsBnOmkZUASfc@nbf}Ta^x>e z=8?Q90Img*ixwSvWeS9Ldbyyy-}cL&Vd3>+NT)dM)kiv&aluMC;w5m2od%)dz(910 zzm@i{jH;#p{@2}qmEL)$29Y6S6au~4;IY>YO zVLNf`80_7*|EmGPb&nYhdR#1oY?mxRry1$}+nu#@^3$2Gr9s9{FBd=)Vx(4m^3jm9 zr%%APUkX$W>xK(^{!P&QuhZZ_r!E;^N=C#A&WI@Ooaf)_TFtli9b}kT>xX>-klxs_ z-@{V{n5`47f{_zj9A!Af?%D*Pq#*q6`Ovso@PJdR(Et!*j=YrQ0xy7g7LjpDTi5=u zH;5E0MxiK#6&n+JY}xX2XiP#9nHj4R=^3dtd}nI=PTiIkgDk>u6eo6`I}m(zeB-vO z03zH8Qlx9hw;_G&#{Bv1=0EWmDVJ*hSW>^L7yydrwq3{T)K5&^i!6h6?jrdu+CacG zVZJHQsm~~!PK&`=y+Z=m=tm!a3}7_jsy~e3vStkVG_3B<@QHJ~Kza<$iX#tQ8Gi}j zlcvu}hcvgq0@_FfWl_%|gIJXhAP6Z<{Di13RvhWy02I-zlE;Cnjr&t*Me0yrR|NlIzC z8VMn`gNV9&K~V|cY&dzc8qa9gbAtePN(1*d0L8efo3!fuIr3X2^^#%86PCsjWopr; z({fZYlnqK}UQR0gFENB;#!toL&~sp_G#UU=wZB?JD#;ro#y-|Tz``XfK1&V|1RkCC zG`cgnaET@c7y(RcXqA>RS;)}kh(QGtV)r)yJd+5IUU>c8W(wb+b3DJL9Tvo4MvaQd zM()E;%pE7lhEvp%FgJqWziRE)$oRz6qliDujSyA))77)FiAk$LUR=KR7x=R~B1E*J%n=Ndq7>1+soS92gqgd>8UjY|{_ZioM{BL1F}2 zXY~CL=&XY8;Ok124I<~yzxdyb>V84Dcs#^ZG3ta|7C^ zBwX&@z2EB$Z0|t(q)|O-pLrszuU_(ZNp@);ZIL)3t zzmC6s>yodBrx(=fq6`u)sYbYOwrbn^7=y}{#yP#CD& zQ?}I?h7Vy&}y1ft^%Ur4Qg95&_uaJ#b3!gUDm+4t>W!Ub$MG*y-=Z!=;fiiJtb@b#JX^=053fVk_^7j_U`G!R_BV+!sgjsCG z2D<|DotdHG^>N(4Lfig4nJV&cu`(zdH%ng*MMLM1cw*57MLMs5te4+vhRio@0737oB?CKBM>ZLb>H# zIS?;n(R)kVL3vjZMjKpzto@1Hx9!*$H&nq;-th9JIKf{c5D$$QL&k~KYAq5%tPwE5 zcFHIa1w)5FI#R&JX|1Mg0L;=xgu8W@!E@mW)Rbzm{1&DBm?u=8LNk%QK4IDmsFWDW zMK;C=%~{RHK39-iLfU4Qes7@tF%Hth%@kd_myLf%dlkulrM*O&EUe4_Q} z22pE>gtU4I+lMiX_RndV??wrjl?$UCrJ8I2cnVTFe6#7dkf``3e21X)i-pW>>ZsU8 z8#n#3zm`zC#5F7F*CBbfYu^t$9yzU6^n@SS8^hdZad*VHr$+NIR;t%ubi_!HoG@oNJTI5sgCJjQ zhZFB2wc{Y_T1#Cy5apjX@8yY5-tB7Dy|K~~?a|PVzl6rESAkpzu!)*40L8d=AjoEO zoL_3IeoFuqPOGy`@$nma(V@Y(gx0tQod$`mJST+E~bhDs^vT@7KpTHY9J<5ho zU<=;kx20Z!hp6??9i1?9etiJ~sf++=_rJG%O>$I1L(-o?`yNV#=U!NiO1`7;=4)>+ zNs|~hAv@=c2m?<3d!uf$Uzw>(GbukWsT^@%c$W2034MK0{efEdE{}6YLR-#jNizfoXifNY`LncDsrOznRA*j)k2~E_6#@O;IQNfXp zC0v%@8I?-1v^KAE&!LY%S_}>-TPBg=jlUiZ4{z3W8{|bd_$&#I5}(l_@5E+pa2Yd& zg~kLxcl<*Lcl6Ay@U%`tzC*%!cw&c%1j;W60a$z3Kn*$)8Sm|L=f4&q5RsHy*#xDG zMg!2LXFr0!r%!b~crHeVFP#rgu;;uQX8dr{g(i{E9`v0%j|9awZb5brf|G>|xTQGo z5_b~9S)%3(PYlL)IDg=t3!jlojmKxh=#UbJ;oxHV3x?T1yEsNy>-gOH3!?>Duvy_O zc*yn`JmzDRHCWJQ#8~VFBUd#2AM;;bTu*?-DP&ZDrCcI{;DsA`A?clmlMX*{`z2L= z$^c+KT7NiPpyrSBUwhkmj6kuaXF6td{gA>dWz5EPT(`lsJODtSAD(-3&VR5&P*^!f z6bcoE@DgIt3MQn*?+W0`x481)ULP41^E|{DY%&0X@{@0dj+rt6zR!gpq$eNl#llDM z@$~l1n>>BNAOr$}(*s*9(W#*~+dcu=amcReTOTYD=s>SA4KK?dXAc@mhTZ9Ls2PLSq3k6*CCEzDV5>o(qK(ie4*mSJ< z(X)Vg24+{jMES!smKPo6h_0WweZ?Ab)H%rp{ zu&CXr%_1|EEf{KkR`EAxp^~s@%(Fc5l@LU$S)t5OJn)`g^qJV0epgZ~nnr^1lk{+) z&m@57F4X*X>~hR+^1(1Z|GxUp(k22G5H`0B1i1@P^LNY`z7?Za&2xT&-ZQFj23T3#z z@}t{Nd;7h-a5Kd6cl&|3mda1>={oDXtvh!&8v#h`)=UrtO^)oKfTi+J%Y3gR!-SrM zY@p`1t;Zj}p%qX;>$bhogP=jQ7eYU9m6#~i>5Df*I|#k~Q1e5_Tcs(#U<6nr-E5(C zryf;;5w0RI&IYHYclgA!|9ynKPeN_ty!LK~+oU%F~tq<{&5yHu>?7gdG= zmNow<(&6WK2atz(2;#Q$#`gbKQQXA0ga<6IUYJXY?n%{hpQ6+b`NWBV+NRr>}VX z2XCEGYy{9syRD@L+~n{e1&9oT2cYOSa0D*Q$;F{QvkU)V1yZW4(OIaFN8YSw7vR|! z7~HdBq4T)UpTF&&-f;lg1kuwAhx)|3N|l@zduVZHAg5$&WDT1Q)FaHH$1HhrwhYSpKX(T@Ef>b7b4Qfbo=4SPffAtPjE|FGS`%`?fT6@0_Z$# z+Rm#~D=HAP!rq&=Bv*Q08T{x>bpM2qX?6?g6FGJ(3K0IT*|aC3Mx#!|d&Mp0K>10f z0GQe$gC?z(9Q)0+>NyxU1rH!FWq*WoxX`Zj0?EMl?CYTl!SkXNPt#x@@yhcIL(wQB$D+6`HC z1%@GtX1s-Ga^#v6FdOuVPrW#r(drHX8n~GU*829<{5rnb8z0|r%hs*GM+#&ym*bjb zDj90C5+rpUW*#P?d-TI6m8!s!lyBao5t=js;X8Ugl1VojMT)p3QxP$D4;JllX3fr> zHJhdPeU?$wAV<_IRCaF40?BnKeP7R9pi{afcyr_w8!$6XjPbNN<0BYPZ3U3*H41z%6CMT=O^S zG8|Vj3s(+7UY!8s^^JTWWd2P?mck8jg! zB|N(e7b-t`t@gC{EhhOecUturY%yX~Tpr}@Ho+|1LYqGa22HWU&kf!FGCdBQFFkAGEg*P z{Nu$7%A8|=3CY=ICS;RtBeCYstx`2V8oK)~Y%eNR#P#Deo&mQSG-|(S@#618Ehvw* zj+t&2&*j_lrvTEO)cRnU6_cNy-ytZr8QFUhp3^P6?W*<3_r+%x+Ct@RL))?!hoU*UT?`X5(ctpIxZ%KQ`}$*M`FPBv^QW^pRV{<{B)i+X!sq zkQGr?(CxP(C@d@};-?VT>yf!#z!1>QA5cJKLm-`++*9L!zxSeN@1c)nFl;cH z%?HI`t&cUnL&^`k5mT=rKfO!84?cr~Oa&C&pO?v9hF}{1z!sZ6!7Eoz;bxcdrzHXl`7vAnxK zoe2&mA$e$ON8ISrZ)9dm;tfu;3@X#z%!bY7A)%w`X zRq-3hay4oNZ=3znqBa)oe6#T}1LLMQ+W^z5IMinrCQHGx^Iq@>$WE}BZ%%dpm^FQR zj_&iy+vf8LsQ6GJ$5;;hyo!5_BPgL_?8NzTvB{}VLYtfn=>egjXI}%fCBu4-DLyn8 zprg-#dBT;O(zffWR~MO&>;k@2A+HTOPhdMQGSuZLQKeKUSIz7G9_Yf*dP%=GYCYiT z*{{CU>gS)2`P`@RRPd{sF(}apu3WjH+N3$Jq_=M0^*yamz-d82aVDM#j`=}1T>=?p zjj#%k$d}4H@bKW#6LF#!?Z2rqwZ5es(y>zsh+FKUQRY?A7-*@0T88!!Fr2rS?`>7x z7C)x<88)-e(0R!qbe5wB$PW-cw{9j-rN2kXfDXDIJw~SV95CXUT6H3RVwD;)dk^J? zpS~-F(i6Fa4@3Q8VC7;J3;e}Auj4;KUkqrR)dUc z3!ZojqXzforwO?f9+SANWA_pLGT(YD5?x+1H~1S%Wx;z_6HW><;)T~e@Ne3*$!p%r z?>0+r*>*-;gU0J1$rVUrrX7ys3yXFnsg&?YFBrll`D?xW54CRn&=?B?3}ZS~$mIt@ z-yf>H0T5~$vjD0!EYv=Z4=n+q&3VE-xUov3QVmC03(r{v9u&zQO>W)wlOBBs4IB0N z%jg+s?`M$kyF_IwC2eIqMkS{(K2ZLy^PI@3Cs(!ey2VyzVhf4**>S9v}hG0Ca*2g|(^?gaZNL3`K>C zu=)*uo-k$l>g}7>W&H5{SG|xH5Ewjg)L_6V4$wt=Pkd_J^O?zoUae=@a?y#S4v1x!JX7Lc|FO0A#>{6e;P;f% z&(VKtjGZ|9k@_hee}bPya6#`g?tXNi8_x?qRRBj~BThn5sm&t@G%pm?%S`ozA6s|s z^>KRFhlaHtGOP7T@DNaT;hnXB!e7FL{R|~tC8Z_L$}Ee*f;D`lHTJJ zonOrzP(Hf$w6~q$g;RAw@g(ZdyT`*K`9qTn^5>s>)e5yG#K$6C zmAFM>R7DQ}XOBS*QKSfqP24(lX6B>Q9`64)&;sZ8qi{0&PhGC{;m1o;cK^6#@*jJ$ zGVmFh3Jg`YQF4y}a|c%#@<76)grjzYRDAj%?Ppy#4NTX^I4vMZ+ao0C?1YKyK@vf1YE!y?w7-xRLPBKiTR( z_y68NrN7ozUu5Krtjaq(x1g#1_GN!sFyh03d&AeXh!Pks_zOX5CB$XBoXKcJgU7%| zpV`UH($;14=(}veyeU88GYAL_5LB-9d2;Z7tE2(IS_qXtynchM$TqMG+^YCB_3yL5qaa}FxDdoMO_b{5ER)h8w zDU1f;QE@3~tgwc~^Xm^Y%E()>$ziJK(7^K-{{DN%rAs&Ss#n*rO2Eu$%!eeAj7P(U zXvpBcIAA9E=fM75+siN-Z$gM7Fd?j|z!)9hAR*VNXnE?)dBwj+_aXpDgLt^Gui}CJ z3TQIHhb-tK09)L-DYe2w(HQt91Z?c9Fd7NFn9%x7wzW!4eQEX5w|4*=5j7Te>%@ys zK)#dzSW*Bz0Awr@2xE7?K$-ZJec>?;w=G)!bv?ir1F1RqTj4M7W}BbC{_e_V4O?}Y z-K2S2tPIUGg3TpS$SQ(%Sd|j@83mgNH@2Zs`tj&9xCda(Z~;sR7kUENln^eBo~a(9 zXZ+yu6=J;i3)M4!SgicGi=gWlhNtqND0Uo47dD8+rPK;_z@d`~S^Hx|) zqZNb4PJQUN!)F5FHw|X~(Fbz;AO)(70ienc9e!J1U$s6=AVrx%B5d_+uEAEW-Cg(L z$7VhmlhEc6gFV-vbZTtB^P8rWxA2>l5zB>(Djde3@CpOWk2h$vIv9GyIS5!oT3+`U zh3fwF19PChfw=tDU!nF3Y802J5!;P#hU^OsB`@E|kMP?(Ly-ovLuA9;M<;FyLj zK7;2s;39$vMh29G?4VT9#=xu?0xVQP?~TEWKu_X<>t17G`OW?LR`hR}OQFJT+RXIy z52?RDHLc5%xtR;QfudWkxv27E`oMdegWDSbbIl){xaIX#Yr_NznU&cVirsGrPyokF zp4%ZLw&iMu5mu>zF@TVx-DT;u!Ju6L+Q-=WhM zuUHd$AJ34Na*clTM|@oG0pkFZ)N|{)4R27*JTBx zh`>!M&|M}9sMBdp3Ke<=<=#GaO@*h15e%k>mp69hTjEhzJuq>9w?6-G@7iOdD8l&O z_3rkHZPP$)>HFaNI9iY*jVYV3bxQHV6ah?qE(yJ6ot?#i8K=814Gh? zA@~Ogt+oQKiC8t&v~UP%D?t=X!b2h{>Gf{c@3*&eFA6!}uH8H4%k9nF-tNqPzuE6G zv){}DSZKE#B?{UMd0WMhlKo-<*2}il8gjo?;;k2*q{_zAoNbIQP;1f`w1Fyu0JW zWo?H%<2Aq=LXQo&a|!_h(Wn3Qx^{KX$)QX- z&X=GcxX}9|5~6&xDFBQVL!jie*>gIZy>6qQaE1uGiHgBZip{S+Oa*Ruf7hbY@-S?O0a* z+N*o^?6as{EBad@h9ehzhDaFFs8Rs*7)%lVnHF2mo4fW|RJ{CzF$@^qp~yzm?N@($ z?_kD@8#k|bX4Trya!QtT(EoO$Npw)^5sVlb&o+^TRM)DDBxOKP7-*#(lbOPsP0H)I zeEBkq#xd|)^3?Lf>uPH1mpr%raT5Ai+UHCBF`h3PVa!9bLIFg>WFVP@U#1X0eX=FD ztNNAtjXO41|3SP#_#i-2O~9I2GUa;c#@8P_Ef{8u9LxOKK4d+3;7F0tb?LE-*Bv<* z&J5VdQ@$nA4ouKQ7YVAuCE;nFUZAi$Di^xLL#!Upju2$L73dI2NTZ%)$|(?u>UZiS z$?Kk@a`j+R#)iv>#5gbDG)!*v-b z;Z6a1R44$v?wMlr^{JNpp6ZwDs@~i3!g=CNE5h&Bj&O59v~xnm)I{Buz9V1R5|R=Z z^x20O5B~U#MNFKYH|7|Z9iw<(3%br;A{it>G(Zsugo8j&93;mW3@wO6QBs^D_s^id zsdy?6=R(1VqDesLG|E?GlfrIMq95rDE~7bCA1}(+t{SuKWu?V~=}D%}vwvSb-`jqu zpV&n#av*^Z+Au+Y3wO>W6pt2NX&QY%(8u9X3~X(gjji05>NDA5r3~KD>5#9qU6e$$#rUVdHD?z z`alH-9vPpwKtEowgVW?9fX0Yu1%RcY;r6Fx=O15HTet254O{-8n-*cLFuiUMVL~Ax zF9HHDwI28(^_Q-;0?F~O;mo;F9QFjS9j;8G?{eC^(#w@Nj}CJUKsCa*W>Sa{hPqWL#pLQ6F!0nrB+< zd*50!LdC$D2^4fzx?3r^{rU;{UouPr)1|JtK3w-zIp4~NU{8P)7oew z5KEE2oxtHga;Rm~5RRuWH+eG3&khVb22gob_8K{=li`asHApCaHu+f+de zISdojgLMnMgMT5fkry~A2t=9!ps-r@s4xF`-A>PX?hlOc2XR-pm4n+VhbkXLwfvAs zL?EIR02BU{tlX{#(eg*)4aToo+XzI80`Rf?w(iDVpU+ld<(6OD_ZPo9jUx~d3V?<8 zCTHb#Y9qo=%K;+8+i2Ihxx1nz`@mKA_!VoxSb z>}lG~h5t?s$^YXB+zSGlRRC;CZ)WbCp6z?Sw5ZH+%YQGe%+KKn+y((HDgYnLU(mJv z<2F9vcbmrJyEy{)i-6`70PFK-Rl(rw*ieO8eVE(=kAxFPfFlql1pWsQrAe+U!@^kr0000 diff --git a/app_docker/www/intro.html b/app_docker/www/intro.html new file mode 100644 index 0000000..f61794b --- /dev/null +++ b/app_docker/www/intro.html @@ -0,0 +1,438 @@ + + + + + + + + + + + + + +intro + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + +
+

Welcome

+

This is the freesearcheR data analysis +tool. We intend the freesearcheR to be a +powerful and free tool for easy data evaluation and analysis at the +hands of the clinician.

+

By intention, this tool has been designed to be simple to use with a +minimum of mandatory options to keep the workflow streamlined, while +also including a few options to go even further.

+

There are some simple steps to go through (see corresponding tabs in +the top):

+
    +

  1. Import data (a spreadsheet/file on your machine, direct export +from a REDCap server, or a local file provided with a package) to get +started.

    2. +

  2. Inspec of data modification (change variable classes and creating +categorical variables (factors) from numeric or time data)

    3. +

  3. Data analysis of cross-sectionally designed studies (more study +designs are planned to be included)

    +
      +

    • Classic baseline charactieristics (options to stratify and +compare variables)

      • +

    • Linear, dichotomous or ordinal logistic regression will be used +depending on specified outcome variable

      • +

    • Evaluation of model assumptions

      • +
    4. +

  4. Export the the analyses results for MS Word or LibreOffice as well as the data +with preserved metadata.

    5. +
+

Have a look at the documentations page +for further project description. If you’re interested in the source +code, then go on, have a look!

+

If you encounter anything strange or the app doesn’t act as expected. +Please report +on Github.

+
+ + + + +
+ + + + + + + + + + + + + + + diff --git a/app_docker/www/intro.md b/app_docker/www/intro.md new file mode 100644 index 0000000..0b644dc --- /dev/null +++ b/app_docker/www/intro.md @@ -0,0 +1,31 @@ +# Welcome + +This is the ***FreesearchR*** data analysis tool. We intend ***FreesearchR*** to be a free tool for easy data evaluation and analysis. If you need more advanced tools, start with ***FreesearchR*** and then you'll probably be better off using *R* or similar directly. + +Here is a brief summary of the functions: + +1. **Import data** from a spreadsheet/file on your machine, direct export from a REDCap server, sample data or data from a your local environment if run locally. + +1. **Data inspection** and **modification** like modifying variables or creating new (categorical from numeric or time data, or completely new variables from the data) + +1. **Evaluate data** using descriptive analyses methods and inspect cross-correlations + +1. **Create and export simple, clean plots** for data overview and insights + +1. **Create regression simple models** for even more advanced data analyses + + - Linear, dichotomous or ordinal logistic regression will be used depending on specified outcome variable + + - Plot regression analysis coefficients + + - Evaluate model assumptions + +1. **Export results** + + - Descriptive and regression analyses results for MS Word or [LibreOffice](https://www.libreoffice.org/) + + - Modified data with preserved metadata + + - Code to recreate all steps locally + +The full [project documentation is here](https://agdamsbo.github.io/FreesearchR/) where you'll find detailed description of the app and link to the source code! If you want to [share feedback, please follow this link to a simple survey](https://redcap.au.dk/surveys/?s=JPCLPTXYDKFA8DA8). diff --git a/app_docker/www/references.bib b/app_docker/www/references.bib new file mode 100644 index 0000000..ab4b8b8 --- /dev/null +++ b/app_docker/www/references.bib @@ -0,0 +1,11 @@ + +@book{andreasgammelgaarddamsbo2025, + title = {agdamsbo/FreesearchR: FreesearchR 25.4.3}, + author = {Damsbo, Andreas Gammelgaard}, + year = {2025}, + month = {04}, + date = {2025-04-24}, + publisher = {Zenodo}, + doi = {10.5281/ZENODO.14527429}, + url = {https://zenodo.org/doi/10.5281/zenodo.14527429} +} diff --git a/app_docker/www/report.rmd b/app_docker/www/report.rmd new file mode 100644 index 0000000..fcc6d4d --- /dev/null +++ b/app_docker/www/report.rmd @@ -0,0 +1,83 @@ +--- +title: "FreesearchR data report" +date: "Report generated `r gsub('(\\D)0', '\\1', format(Sys.time(), '%A, %d.%m.%Y'))`" +format: docx +author: FreesearchR data analysis tool +toc: false +params: + data.file: NA + version: NA + regression.p: NA +--- + +```{r setup, echo = FALSE} +knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) +# glue::glue("{format(lubridate::today(),'%A')}, {lubridate::day(lubridate::today())}.{lubridate::month(lubridate::today())}.{lubridate::year(lubridate::today())}") +``` + +```{r} +web_data <- readr::read_rds(file = params$data.file) +# web_data <- readr::read_rds(file = "~/FreesearchR/inst/apps/FreesearchR/www/web_data.rds") +library(gtsummary) +library(gt) + +tbl_merge <- function(data) { + if (is.null(names(data))) { + data |> gtsummary::tbl_merge() + } else { + data |> gtsummary::tbl_merge(tab_spanner = names(data)) + } +} + +vec2sentence <- function(data, sep.word = "and") { + sep.word <- paste0(" ", gsub(" ", "", sep.word), " ") + if (length(data) < 2) { + out <- data + } else if (length(data) == 2) { + out <- paste(data, collapse = sep.word) + } else { + out <- paste(paste(data[-length(data)], collapse = ","), data[length(data)], sep = sep.word) + } + return(out) +} +``` + +## Introduction + +Research should be free and open with easy access for all. The *FreesearchR* tool attempts to help lower the bar to participate in research by making basic data exploration and analyses easily accessible. + +## Methods + +Analyses were conducted using the *FreesearchR* data analysis web-tool version `r params$version` based on *R* version 4.4.1. + +## Results + +Below are the baseline characteristics. + +```{r, results = 'asis'} +if ("table1" %in% names(web_data)) { + tbl <- gtsummary::as_gt(web_data$table1) + knitr::knit_print(tbl) +} +``` + +`r if (length(web_data$regression) > 0) glue::glue("Below are the results from the { tolower(vec2sentence(names(web_data$regression$regression$tables)))} {web_data$regression$regression$params$descr}.")` + +```{r, results = 'asis'} +if ("regression" %in% names(web_data) && length(web_data$regression) > 0) { + reg_tbl <- web_data$regression$regression$tables + + merged <- tbl_merge(reg_tbl) + + if (params$regression.p == "no") { + merged <- merged |> + gtsummary::modify_column_hide(column = dplyr::starts_with("p.value")) + } + + knitr::knit_print(merged) +} +``` + +## Discussion + +Good luck on your further work! diff --git a/app_docker/www/style.css b/app_docker/www/style.css new file mode 100644 index 0000000..fedcd1f --- /dev/null +++ b/app_docker/www/style.css @@ -0,0 +1,125 @@ + +/*! + * Copyright (c) 2025 FreesearchR + * + * FreesearchR, CSS styles + * https://github.com/agdamsbo/FreesearchR + * + * @version 0.0.1 + */ + +.container-fluid > .nav > li > + a[data-value='FreesearchR'] {font-size: 28px} + + +/* from datamods */ +.show-block { + display: block !important; +} +.show-inline { + display: inline !important; +} +.hidden { + display: none !important; +} +.invisible { + visibility: hidden; +} + +.container-rule { + position: relative; + text-align: center; + height: 25px; + margin-bottom: 5px; +} + +.horizontal-rule { + position: absolute; + top: 11px; + right: 0; + left: 0; + background-color: #d0cfcf; + height: 1px; + z-index: 100; + margin: 0; + border: none; +} + +.label-rule { + background: #FFF; + opacity: 1; + z-index: 101; + background-color: #FFF; + position: relative; + padding: 0 10px 0 10px; +} + +.datamods-table-container { + overflow: auto; + word-break: keep-all; + white-space: nowrap; +} + +.datamods-table-container > .table { + margin-bottom: 0 !important; +} + +.datamods-file-import { + display: grid; + grid-template-columns: auto 50px; + grid-column-gap: 10px; +} + +.datamods-dt-nowrap { + word-break: keep-all; + white-space: nowrap; +} + + + +/* validation */ +.datamods-validation-results { + display: grid; + grid-template-columns: repeat(3, 1fr); + grid-template-rows: 1fr; + height: 50px; + line-height: 50px; + font-size: large; +} + +.datamods-validation-summary { + font-weight: bold; + text-align: center; +} + +.datamods-validation-item { + font-size: larger; +} + + + +/* modified from esquisse for data types */ +.btn-column-categorical { + background-color: #00C896; + color: #FFFFFF; +} +.btn-column-continuous { + background-color: #FFB100; + color: #FFFFFF; +} +.btn-column-dichotomous { + background-color: #8A4FFF; + color: #FFFFFF; +} +.btn-column-datetime { + background-color: #11A0EC; + color: #FFFFFF; +} +.btn-column-id { + background-color: #848484; + color: #FFFFFF; +} +.btn-column-text { + background-color: #2E2E2E; + color: #FFFFFF; +} diff --git a/app_docker/www/umami-app.html b/app_docker/www/umami-app.html new file mode 100644 index 0000000..0582053 --- /dev/null +++ b/app_docker/www/umami-app.html @@ -0,0 +1 @@ + diff --git a/app_docker/www/web_data.rds b/app_docker/www/web_data.rds new file mode 100644 index 0000000000000000000000000000000000000000..d81c8b24c3dbdb079353ec4940d2ce756a9ac1e0 GIT binary patch literal 1737943 zcmeFa37lM4btl~2D)pk>mTY4TR>`X*tVZ3Eyn(F(LyR5UU;{SbrK#?&mI_x_wX3UT z3n5Zr36QV`NCJUCfFvYgNmvrd>VZrqlSyWhnPkXhW*Eaa$$Z)7BLm5A628In|DSu$ z>w90ls(P=xs->3i{ryheceiuSJ@?#m*Z1lbn+663h6ZxE!GWO-eB6m2JZzx98L$nI zFC4)yT;yN-2Xuc}I5H=$F!}jIbcM-_KLGc^!Zq~ZUvJYjzvM!`30wZ4O`o{K;2XE$ zD{Q*@2W))7ASm3d;crVs;Yic)_iXV73W{gHA2so>dBXUW$BqAzrtxnVZ=mp!f(gIE`qPh_u=>h} z@~7qRwfP>f6h;Qn>QD>Kd|>7zVfaITKv&>NkSp+k1P=JBZX06Z=f(nG9Uk1 zVF!?1`lWjcJBjtuFBNu>+H1d2*lP7HqHp=xYRf5~TK+s+ew(nhFT%5hT<-nH!WK(s zhv6fVL(Zm;SiXiV|6>;4W?SFQw*Ff*-Nvh&qI@=fhg9Q51?6`eYrE;D!UdMj1)n>x z?cUtQg$s(NzJsQ|NB_yx@96)r^4(zh*kbFoS(@WiVVl;M)%%C99{rxJ$DlON?xX+v z$kEsR-FuD~#w?y;TVDAeHvB|#IJjiwG_ldN@8pL}`yR6GrtycbH|_LnE04prKG*)G z>A#bA7(JS_;R%VJD@@q-oV58T{+SJZsxa}#ru`=#rr`dzaOg3Ef6~hFki~OY8s@8o zgI{OGcNd~@M$2#U=^p&NC`{p?Eq}n$)p6y3)u&0r7g9NX=1ng7Rol$~pXoGCeG}XI ztLf^;b1U75kW*EiW$E z=b_{Jl$)&=8yfqlKII-+EX`=_iA8-X&fBNlu~M@%gx(bNn{8vII9<}_i3PZ(u*$ws78uEa_6T~LvJ!Su zmg$ns7g@5&OYZGX?777=lTGIBOdAN@!$y-wcZbO>RZ(nz&(nGQW4? z$oS#>H=FOxPfm_szbqR=Xk=m{zxU8#mEZ7n`Mr~q8XB26oZovGi3Zi93ftD!=p%@}Zn+RdaR~J{sl!N|xHeuU zUVSnT#1DXVbdO9Xsl0Yfbu`!^h-mQ7%WTD5&pw9i(N0h|T zcR3rLDODRKox-LMvWF zY8f^bE9GOFu)R!mUZ|J+-tSEw&zrB!mgi1R85`kDueQ1gcWI-$kxItPxd6dA3oi*jrrNYlaJ3$D5(f(qKzXjr0bk*+V$(Yac!QLQypCzB;PQZFr3iZhyNxJ9tsK~Zhl zDK%OSYrNGSvGmB&tNL10Q9X6z#;<1%qp&Wa`%q`CBkdNQhR{NwRx^qpU3Rgnf&fps?OG?#5$Wq@UJ6|s*>7GZ>Y0@fdST% zR+6=|mU9EFji+piVdRme+Tv1O&D01(&qH%c2bzh(S|)f44AfHQ5| zioI7cVMjCUXm;4HmC3lT>B(Do&faD6W7yHO=C)sg=<|-ISv7b z40GZ_+G5U}=Hp(q1?naZ{+Yt}SusC*mXnx|7b_t1uQPb{r(X28Ad zSO08KM*S-6otcLB?oN0X3GK#kB(b&IJJV&9uja4{-FM5_AEM&61A8mGXq9KH*GnD4 z$w{Kb{Pk>n&m_L3U^`^k4{P0<(1kDBF507r@447LiZinZ7;oFKAI7GN+KRoCZjJVl z!hRSx%OLMFv>&z+2633j$)F!u<-yk@!0k3O`!m)qcV)SHWkUSm6*f|B`o?kI^@~N0 zM(5v#R2=)@j4j}f4z_C=UfhI{`SRi-&VNvbd@In-5HTJ0^JwUMId*`IH+Cd%Nqc7u z)hQfR&B)D8l$M=A-S8xnvCZ3FG0f_t?$NZMJEOykC+DYY6%_2mre*icu{km~-10Z03uTE$VKH(Y+Rd3*1%fOE&r+bxI%dizR7du%IVCuNx~*?f_OqfMEFXva?$ z$GP{i#z1%%VPIt9?0FX<8oi@seyW!+Ie|DEjyB21rJNP&%b?tO zQEL<{Q&rhL+bLs+`KT0k8vq<@T0dBE*bX#<**@SPAFNoPh&lB4MHK4~F^*&UBZ~Eh zxNQe%{nSbNFS>N>AZIP&wtBo;j@KXJwtBo;QLI12@eZPwA2WaUfEFiOw&|wpu={Di zwu8&LN;BRu)}o$I6`Jv$widE|s?fCeOrlxkTFCaPLK8be-rQ_0WcyU1iL=%GcODTI6GwE?nHMxQ8XL2A(wtKCP?B8N+RJyi~Wu2)jQTtX*{?$ zS}#v8HE?CvSd&d5W?e}mx{7F;F9gj+{U8m@>4GwJQU-f=139^Ku0j2*&!B$MY*4>> z9g?`l=$kZ#=jC&(dJAJ=@<{Y}oj$I|JpScA^CvCFJn3J(n2`Pd78_{$tdtcHx;h0j`5`SOL07+&y_7h=f)RghJrE9bm2U?l50 z#$9PUPQn-$k}&E;lY!MqW7vGw(+Yd&ZvB4w(A|2vxqfnNyVt(BlE1^bJH8xyi~Jo~ z(nyz_XE`<*UvjKVr5lE)N?w0NU6xAs`mem?=v}q(JjUnoXh_cAX$Rx<*O!pm`SlDZi(My*6e^GtmGLPqNfWf2x5x>T18b7qI z&v`tXe1BjvIcbb<&G%ng@@-Gd_w|;1TN3mASxY_~%qGzNotAuQ>%jxM)_VL&3qD+A zNXYl4mV9aP@lddp?nhhjrOlVNJxH^a?w?0=rM>N6zaB!Y36Goq>WjkmKW3xw@wf3$ z`aT$iAKK@K8&4ofoWb|d<2GpVze0mHJlE6+lYguHr{lX3X~OouC8O|m^B;;)cvJMB zfhK?MKKU=pD1EE>Z^0-$@kRM>#VCC6n?f)O+y6>Ln4401RZFg``%xp+C45PsJY#d} zyEuujfB7Ys?|peBc=z4UXzsH6aWS&WAg`>a%4lw>r^?EU>8UcByXdL1@=AIvW2JUX z{?*Kn<_&W{X2j1J30x=c%aX@sRj>7u1#WJxo181YXp)AG+;aE(qV`KL+S*4MX`Se_ zexMI=S}yNAGpidfWf*B)z`=gJ?1DVjRvvbKlH<6_uVcWC;Pt;Na2YeQufwzDW90@- z14sQt4Mx0myv7uj9Gxy78^_n$A4Z&OP6w|s_no4QTV_i$<@sVIG4ptgpN)%nx4i_E z5j##Nj46;`5&V_QT=_9u(q#xy9)k$_B^Q_GQkSF%&gVOn-vu}~hZrxP8_{_F#WBT2 z1F;9d$=5{yc8F&Jm`0zCvm3w$Vwm-2m|y5%n3F7q`IpfQ^BIUGOP*Q_vUr_kq6P zO+jDUyASjQZwmUNUwxo2cvH|9eeMH&!JC4<^q)S^7rfe!_B7EM&b-UgcRBc72HUZo z?X%cE$2N+MLpa!C=wiYc5Nt8z(g#}*Y%$~-Y_T^0WVOZdg@}xAob#rbvCCMLGOySG z=1sArkvWb_UzaeV@LmFzE39$m6#!@EYq0{zgN{4nXYD)9__vxF|3V4>k0yW4l`zam z69JF-NS9_nSo{?XL+z&c&pOMe_)`Bqm{q}hrp-zU`e9gw()XeL#meXu`DaL|xdL6RPZSnqYTg_+LMu4oj!z-~!u~6S02lUOBN=2l$DrK8l?Lcfim^cUNyGkY z%hga`FAHma=n!nN^d&rs@9ZhWukwa-eh8_<73RM7wG@3ltohMCeXw<5%@4VTHGit{ zc9eIadaZ+@?{|HDMEYp24q?q7$sp^Vhn&5nu!Uj&6?)c(vEW?Te+_GXV~eFP;Zgi>x8MIfcsS<| zpDE{kZJl?9HGf$1cR243cl({bl4~LWw~BdgSo1@EDdxFh%`cj^CO=u$D&a2*mgkjW z&A&QZ7|veO*}|~qhn&KiKfKQmH4vMDHNDKE5Eeh2^M`Z(aL(WHo|3mh~d#CiB;@<~M)u8NS;e-seZ3kUL;0`b4nBu)V<+_vWvG zgDp1y1E>15PHk~G=Z8%QYyPn24{QFg=I8gJc*lo6zHcgPe4b~A??%abEzC2a3mxt^ z$o_F3&KANsKjfZbeG|_4A*VHRS@vzhIe$3k-+*<}K(2`&xK-?bhI4+%FNG}(=lqaU zAI9Qvw;yul*;g;-#d+Yl3P4Ajunq7X2H^PrSl^SUf$(2_kVA)g=Q%y^Nnz_`Oz1;j z4`U7VPWLy%-TrX5zk>}5XG>0B$u$vxTg5y#tob3o6t@4I9{bexuG6!n@IF6u82icL zZvX0RVVH-dvxQ;J4>|Q=9T3+1kZV};4-D*r9OyW&=6zw!5B=+d ztqXViA=hxXKh@gnOxeEB_xsrQQ`p`x&+L!<&xLtrSo1?S!kQmKfLq1>XIS$?e!&*Y z`BSH}PqCSOm2`T2e=k$JeIOp%peNx(Z-ZSU^E$@=%0q*_M9SA4fFAe{p68=Ml zV_>**h5iw2@w)!DN?7wlhr^mbtog&5Kdkw~nm?@h%e9vOED2{z>E?OioF8)P!=A^v zaJCfA`OQ32`UoDy$GlVasSp+)VQFiG#Yb4*X$||YkOkJ9m3)x9R8~h!szh-^fD%;ur)GP^{cO?pfBy)2l`>Gfqv*&Q+S_0ywBg^ zynB@Q1A5&DL*MUupHarJUdtWxY{8pC{$ZZk2fc^mswxaYGT-{+S(0lN1H)}Z{( zwCvk#Lt}YIVi7o( z4Te?x6e*pXPBzJs!%lZLud;=R$SD}HJ9P6+P7XXyxHU&uZuxd%+rfG;R<;eUFMojU zgG3HT&gk5#GOVJYmeINC6b0iQ+U-O!>GI^{Kjg*(Rcc-nv?5)-3s->5vg=lF(xHpj zo2uc|qd)ad;C1EoJ}mXnpKkSLPo#_2o7O2sz06mis;fjt0s_QRPB)96!+ zcLS(h43h_jX{#9K%!grj=ELwN0Mj}1VVL+CCOw8Jk38Ti03EFX>&>x`&as92onX#-iHeZuJ{IPunFu*J{~%t54& z;4#=@2qDx=IkAyFQfH4~Jhn&iY`eE0 zdkC73dmCK)IeQ!J_P5jRxv$M}%PP+p+8+rya!6UHa^fR2TBw6Q{ku999h!(j&nO5)dnL?60xy!CQUAd-9N}e;(Q#==0JhTX% zpoLnxh%7uYZ#Y{CXDjxsiVDWD3S*a?^~8Hf!XEo5=U2Vn*GNHE_T73-7xfPNd1%iR z@(=rYeb9U8-??zMayXo=g#El+6CDJO>mUnRW+p5XY%ydPY_VBSbIr`VD+zOuu%Fj{ zKQGu~=nPgl;cNwR2(~zqLDsP-oUK5AQjA5x7Pq&>;cNvul>Mxs{ka9uMSJa>AJE13 z+PTB#&}?_k6V6tAIi=f!KiYZ@M0v9f9GRy(Q%ZOj1ZceWWH_9yPzt_Wc&5aiYDebn z^gLa=hWAz|VmQv2sL|YMq_2DUxh4X>%QT~ikEBUw58=I)^tZCLUBcN4mD0V(j^Gv0 zT$z{AM#R$MVQO)BZv}FK9AwUqNAVF3Ye)zqtRW*AWU}~>TUbLvf8rxw*w0Hn%JIFG zBjIc%?C0g0=tywE7DqA&wiw-lcQM@gU59rV!#jl1gS?+CIuvYim=}9rTnM%}*kY># zS?mbM@L-EQGc18DGNdi;dbWb~yR1FJdn-oR<~u0iY=zQr&x{z>GY0Avotw_RcE+dJ zYhUG=QaD?Q%ifWB$}^?IL=ic*Bc0ox3~PJSe$%<>;cO+>q)a@Q#X7g__#~Zm&^qfL zey-`!VxZ^r*n`)S9#5y&l3sXk1p?PkIjzu8EEWXZLdGXPSK?e|T>N@=IZh!aIbJ zQy<1cvGKav*wX}&Gw-tWA@1h|TZ}dfcaDtW23s7BM_Kw2$F49hh6<$^i^9CP{k%Aw ztw4t|?>&caf{F2V_tF`Gd5O%e!`X_A?{e0_GluX@FltBmCRn!BW_)A|XDgyb?oXx} zQyO`OvlWOpoUK3zJWCk`@c&f8*-G@k8>763+UtFdc+cDg8gyJ6axS6!ZoQ_fcvH|1 z|8k6W=!5)apD=~|%&S!eEOb*L8lj5^OQrFr2MG2ynp`M>5Dd7KO7F=ue8VIGnA7vlX#3&KXL(?-QlF z*B{PS#CC_X6%j*pro^`h=v=vkvlSx`h^1Yh3*Q6_|F;75NIE+T@2$|DbaYu}jm#VV zZzcTSO8CDO8KcA5O1PiLv%;{3^hTIWBMQz|t`BD`VLva|G&&Ua^TK}K3eVQUIk#tq zB@k>e#DG*mg3_0%<*EqIMXQA5$3+ILQ;BC9P^)T@tx|>Auax$v@6uE^G36L4-CG#SeUX8 zJ6B=nD(qZ^ohz7#FhYl~cIrss_*q71jz%|xovW~Om1`Oe3ah2CTCzHj#g1?+3OiSh z5w?$6WEgC5*trT{vq#6tHSq(tim@o{TtR+e=StK_f3n(Q_lql6VCO}~H}2B7|L#KM zu`u(>ZR?bIWjDVsyFaXP=Km4od(>M17XjD<83rEl`Ht^y0B@u*o?J7`JH-t1yZ#Jw zua4nP?_=kYeieX@bhy{Wd!lsC9pz_Xbt3e+rv@kQHEU}iEUlsvM_43}aMrUD*-=1w zkr#a3VG#N$dXn(f>vz3U(3Sf4n(o;$n@drDY3DxFU+|`&e@?&SsPEW4v&kN@<}Rzn zz7e*9Wuz~D7wpnzuniF>_tR;Uf^7@7jbloRzAa-(A8d=@O+i1{HndY8@y)8?s`KAeVCVpc`@Xg!WM;jaewqrZ2UU6#bN&yx&d1)^BO#gk8n6!s?L@kvvR<^ zPtL4T*qXl1ds5JsF(HgKXgD~vO}QpR(VU<2_!Z6j6<;`83g_m%?qezXb~rajAMUl> zVGF`M8ggA{wk_;uqRqm7CWHWoKCF;+Tn~L8vP&`cgf%qe)Q7R>Tv$T~TMXR@wirTy z3${3tLDsP-oGn3rQjA4?-DA;ta5(2*-Cg-`wuDWlCKMWOr8Y4|UkLkskZ&L6Wx*Ch zt|{~{*y8s8(Gbp-phMwoDJSog?MT)Wjt${#DV?ne?=3-2eR5gWDtzld*fumoux-J% z@qOVAwms}GLq58uUMJ_~VL#K@HreyXqxi6OGEYHRe1v80kFfX%x4SbW_eE2zB}RF# zwAX976m-KHx({;4yf&<%A=ec87uL|pYoqXWspb2a!4{)0t#lt1<-$BHoh=II{QVgV z#m4JAIGinovnAN1FfT@5<9E6EeVbhXI@)-CvkU$?z2BE&UKngK^q|-4LFm=FV2i{4 zD|935zlQzSu>aa||5^56bl$m6_Fsc-3$_jOzhK*fZ9C^|TR2-Xwk_;uLJnN(TF7$$ zf@Q*fCS(`Z(B}I+9rjSd*-|)L3g2Neb~c>zLk@k|PYdV#>Bgd9i-Ro=wm8^g&fmpm z23rhefYbfST$7<_O+-0mT^F4d?^0-e*6BHa*nfo%hO?!x{~GpR&$<2AVB3Oi!@MHc zwqV=NIolS_mW*u+XG^PFLxr;?$S<5Ng|j87fx0aF5aGS0@ZQn}>;Vnrn)rdUXZ$PK z&kD8}@(Z>&*kb8O<|o)<$N~G4VjJ)%KEmN_3Bu63QGGaD3APyW4YoMgVyJ<-thPAp zzd~~1Y$@!&hW*!bZvQpdwqV=B*;4njwJ?uHKhZlv>*SrxaJFP@TR2;S9KwEPB!evL zAIdG$dDHSE8hbNjEswguaU`BkuO!M2@qwk@138QT{2Ga-jntRcgDOORiRHKgcSxSt7O z!RZ~NT$77U%eSA5|+OyRvH*s^d}9(^j@l^+=3Hy?J6&Sx5C@4IlP1A^)(S2_eAQZ!?FpCCDP2 zErqkCHfL+W7Ki`7>$ZOx=Ebm~VO|``Ak2%iea|4AEpbBTyDT~s{%u2Hv910d}C^^s<<94)~n^}F&o@is@H3E8`yNLu{bqTt1Qh|ahMH$ zbL5w+i=ifdV2~C~eDsy!jkaWNrdXd%cph#{SEgp?Y{~|Nl+JEvl3>~#mzh( z{*YXUgY-+ulJlq3C}WJpmg)NJv8lzS`T1h~B=UfL$%{wv5svZ>O*04FbBPTpyXn&@ zwvlpmrm{3k=8&AX$>Jlt$A-ms5s%E57Z)jAaW`A+5!Nj>c}ki`@*HiOM_OF+6f8Me z&_O=E_|PAlS8B~abfijd)<&9NQ03S#b5h$YH(Op@usMc~>r-yF9;w;TqpEPZM;1#n zn)k$_J{9NfQ|?%)s47RrnFjTgt$!0G;k5p9tn}h7E$xb|@%EMSsCl;rm6k(!Z9!=z zgtfJ_Mbz(g%ZOs3WrnyU<6pJApY+~Db5O1>)t1m5y_C%}#YX8^tzMofR$@u*3$0bk z=GpSh@mixcpTKvAr1n+vYwOw9Gpo#87o}8aY3QebLQ98p6ne-g^gxq)kxxH0Uz#l! ztEcmOPc2LyIi3Gz^S${~3)dYvz0Zs{8`;e{D8P;2nQa{z)v?NAW2$ky#F0e$3r7&Q zzvOOz-kr}wA-?7wLn6mG+lZ`yALFj@kT29r3#IDp)B?(a|69n({}0#%;BW;;Zscx< zOLXuWlOUH>y@YX-a6U187vQX-iD}f0rxuYNR_S5@Zx>wzAZ7lWF4O3Usn!d+_0+Il zVmTbk5-b(;w+}rfSSrXhSSn1wk}Z`#G0Qh8ig)s_>E+ox%2T$2d6o02_@p<#L+49`UsRp<6rlxDN++tFUET~k7 zh;CW)W@lwXXv*y18J=t|sT*@^>nj_ozj17%b4%5kM!AL^JgJ*47vZ6t=v;itC8BTB zzQJ@SKH_$$JckrgkLB3pmPE4GXWbpj#L^pLr6Ybxg>J?CKKB4hC-A#DiK6BsMQtCS zcc!%AB`T3SwzxEnd@eTEij3VoAxqr54<%+Y8o%MTyYDf{A`7Q2x^ezu){M@TUAwTu zqbGAGz9SxJ_3fmma|s>$MiCe9d&GGa8G&POU>{^TJ_Ej=c(gpzSU%x9b;75X(^+}0 ziOg^o7yZOxq20Koct)ForqfR*yz% z7>E6efjt237*Kzhm+eBI`!2MDw2`|3++-wf(z(foZ--Bs+#tEx#*tT+KM%k*V*9Wx z>%=(Hv3lp(k_6LvC)=C&m_NZnuE3%Y3o$xe^u)3dFD2^Wz02j^iOttzLsnuzSO;o^Ln9NfPGq6N%kjrhd)Z(1Dh;6vO0Yxprp8=(W^xqG#i^&g^?? z^H{gr0Ccu)QC-=JT1WU|@3pQYO_ngSA&!{KR7a)3y2Z2~^lcTc@CI0t)1;028}keM z5#eZt@M`K~%5T(dL=_-0P|dVrj=J6*>k`t)3CLf{d~tj#psSilgk!l*Kp`uzVX^=l zk+9tXjZ>WJ(|B6Q)Hsxp)+yISz;~H&DV|MDgQSyOY+4rl{hq9M8)#&LqIyI#$c~|5 zJj%p_^|I#8GhZ6da(s5m-QnsZ(xP%JoMd|gqC;l|1EEv8Cj+2^ucrf_gSY1co`ZW$ z20GOgD2ZxPq7Us8jiiO5Q}Z9D%tmf14-TianqkTu>62$65-iyYEJcD{>xso6-q@s} zrOBycjK8W2#{`?2#_(LZ(kRt|jV?}w(>F3|)to@^ zmQHjNRfwz5Q8>yxY}$oUaAZ+)kp*rJIxIw`hHl~(p_`K{SSP1f86<6K*9^mY-58mC z`V70WNCXjKlf;`}gj5_bOO@c0jEZ!|a$E#$z`< zxQ~^li?=-YQxy;Ka+^TIcJA>S5lAPtKkKCBp7ifh0OW;WhCn&TQw#D{>^vw4SQP#{K*EiB`13%v$XNIJJ&C z$yR$H81*pC#6q02X&8@Dp$%8wd?kV^H9UH)!lD-fl8WxM^h}SMnlIIlv9AEtMHD29 z>Op`CNq6c7_n3?#J!X6wz@hQ#cuVpwqLUu6pW~^23>SBBoxGEAT$lLi-V%nqJi|}# zrZo{S%kNeI0i0_nh?hgD!&gfkFYS`P+fVoSBK~}bbR>E0itu@q3!Td+g41rirpJBN z7t&>0cBaYM;3|=45d8P zrgM$_Ri|`h;Qe7W2d82nIrTg+EDZ32V7iCO8x&nwC5y$rd zBd!N^uu9qx1dg~4c-+Og9UK^V8M%ya8?pZ+O%>VBoGnq$Hv$+Y(^mmlGujc(Y?z0J zf%6UKah$b1K>eMEAqf+z`e>7r>D9USQGT}p=&U@1CCYPh+6@VuFJB?AGJO8 zryc(k3wb|esgMVXk33ub5|hF(@gQAh0daA<=0)qZxrqXBN%bO4g5xsPO=+ChG#FG~ z?RG^#__5=D4*v5SZDfll#dRgmX{*& z5kD7dDkm=LlJHXA#7F*!p9?nf%eEq)oOE!4!AZp)z|{cKBYn2v4FEdwLHwj^ukFZU zj$uwxl@H=%K6iqHpz4b7!ZMs30;gC5__7evo<7nVnpVVJafhR{kC`}EdYhVQ(Pz6nt38Mk)}BpD zsIT-M_|b^K-lhEHnh3x#pM^~ILK)Fi#dk@Q*t%8n`GABr#lhcl zK$7tkE!_c$?v8>sowW(^J}=8v-EEDw7_@*kI>Tn6X^!J_JU2s}rc;PidZ&{6T;s!Z z8ZRfkr4cv{YnP6scq2gR4KKsx>cUcE5n1SBCN0Xvubtq$NWQM*<9V3wen_8VkyF0qSSNN&)sjxT=#+0c_K6)qd1`{9GGkSK5cZBqG@g9M zj;dPf89Sb8N$1MN;nU-T_`4iWdF_VmJv-*%IO6ct!uO?qy3F`pxp4e(%6s)fQe3`z zP~zDS6Za<3c#r1ZFdeO(;KSWm#N3u4|VA5NVRURT@A)(VKJV;#bYld*&?s-)Mb zbiH<76VigCz3&8)sr^ruHCKy%>(o=%)tq+5*IVT6G62^x9PhYZxe7oBWfeophG#j1 zWvZ(9s2q&nWztd|!*Xitb_z~q5kAf-F#Ixom7(s%Af9QS91(O~COMI&&~>J;z%SEV zrLF5@mq?fAOgzLD$eAL8m1rx7&4X}sIKU}#T>S3xnfW>GVRO38NZZV2G`2bW;Q-62 zXmU*i;MgPl;Bh`@nQ!S~E4C^)k9)%{&IqPGO@OpMQV2{_L!vU(c^2>Qe zoL};(+ZB{I<-d}{0oql!9obE|)kU17$qjYN%RNY7n@|Si5A6^gBoL4COgY87D58W< zwjJe599&8uEOs9Lx;RMSvIV?G;E*oBc2l5C6o&Ck za9k!`2ma_Ffy)hqqp_5Fjc|03Ks_R#To%&b1IXHr>@!LO{%c%wI?_ZU9O4Beu>6y$ zUgR$iP#`FiwJvJ<+topJ zLy5u9L=W;0ha~uDC_V#St1jMFoh>~E5psR0+D-|p)xx7_D=jS~7mbV@3AM#?O$6Xn zv*BlLk#p*hgd-I-ngF>`7U7UY^rQ1DQqY?W${}vQzk)6^1J=E}!8hnve3ftqG(>s=dJ6Hdk;JK`)Zilj>c8S(aK2q)}ARqb92$hc-$&KZ?V)bNtVF{9_ zfUx8bHR8e=J$2U<|0(5kdU*++r+~Z)Zs$|w8hLs3;cD&CYI<=AnsZ!S?gWC*V-y`{ zBdB+D+K6X8S(L2{q;F+D+Hjk9o0c=%i)Q59s5c0h$xU$n0f;yhICd~A9mWuja6`n) zq8sc)D&3zYv1pD(1!WTt_+KWF@dnKZrG35HFrCAJsQw+#Xmx6Fp*T}o1Ok-aU{_PZ z5TaytMV}19^@?GODjMCpGdjF@a(=p2LBURJl6|-{$L5Iq%NFM5t$b=Xjc(PDSxhKe zz7;*BGwMf{YKu#C{d=$0FImep1V~1p2dr{57rz*{TN;y7_!qIosYlC=<5T?ff}Y-3 zC5bX`ot^W(J1jcD2@cylVcO+PpH?~pOFQjyIdK1<$mp^6$3G^jHB+x*yuU57^xeNJ zYRi(xr3!VR$+hhHcgp|WJM#hG zH0G?NmtPMz95OuBIJuy`&iyQ@%>naiatOv2Bm57mvOhF$USB?MX#szdSDIySmj4K} zraCzj{_(3aRl!CB1{T^ES_KSlysFw_C35`pJ*4AWF_Fo{+){rUM;7}WEojt$M{QF@w2dY1usyh5KF?##nU6_46jj>oU`d2G5Hz;4Ab zk4+h79ax4fpm=$_#XLN6yaK>{Jj!DnkLVcY(H+aNZdy)hUWz#8Wj+FFGB4wZI}gw@ zad3hFqI1d1rcN{<-o(*7`YXHPc zTtfhM4a!JqOyHU24q5*&e3m}~VEIXame(@M*Y!5fb@0g-kAmL^aQWgfG4Vea;PQ1N z!o+(MfPB3l;PQ18VU~LyfP54Har(E|wCBSo{TBef0C4GlAHu|QE5N1yLWD{GMF7(O zA|Q$W_amP4ZwJKb-)YnCfKU2&0saKw(tioUq<=TSrT=1tN&g-I>HjIfr9Xi%%e~zC z_rhoSBLMRAGJuv>zT*Akl{W7y;H$3Qk7we^1Bm|t0K*Rgi1$?h#rF`NndjBk=kUY4 z(*Wk30+5FpfR-uYnPrXvm}d?^9XJl4jLI-Fx4@^2UISp>iuLEMPu*tOhXKS-omKp4 z>R3m9w~jRW43kgdeFPB4w}iOM04D&<(*UTKZvl`W;?Xi`+C=O34wNIlcLGS~T{iq~_{9Hqz)JA`sKxVMi|0KZ@VwvV zc^`ajW99G15l8-5Kl1kzHcb8){(ucDogYJ3`Bl64lZazoJ_w-he+aMv@L}l66Y!}k zKLsE@rTbAE{%Pxf3_kf#Iv>F^<<2m5?i=u3dvO$D;!Cnun)W=Tldl3mdHw{RS?*^6 zO#2ytru`hAnfCJl@{$KI{0jhvwGDsKhTjCA>7TM;^2+e1ZJ2t`@MmoJK^y+84XX}( z5@F@xmu#NTS^x9!$>%QvG|v}o+OJsuSK%|y7Xg%69-w(uS3C9hUqgQK`Rf4U`7(fb zegmL*ehbe``)vTz9tUWe($N0-RirWRR{*MS|I)_&4t$pXT|m3?|JvsLJ@{Jw-`Kd{ zcgp<%p2_#W1+aaHli`17!*7C5KK>A(wEhUs%=7O7O#5TNO#qg?9q=cBKLy+jV4Rlw z8lGA1KUx3Jt^c3l6VIOk;`REkHqU>v{uA)YCv}-+z7AlSZvvFgf5$WF{H68(2YlxJ z3xJ#V=?MQ7U>D$Vz#af`{|$is@~;7`7jd&*e+T%V0M^T;_br4;?|)hU+we*6?*T47 z(qXwlz&`?p0pA0_-S#AYh5!tI2SDefql{Ubp3jrjnM!%8IE^L56jy^LbF@xS45X5T z;k=pSrJ0APs5wNaD%>9=$eg7ms{W9=_mLA9!VjMZ6<`cIDf}qllDOd~shJi1s>ng0Bj9WUiijpJHJ{uF-XPRZ%hc|2k%Ty5m%mlhlO=~BK@svc_`M^60dNdD9W zvefE%;cYy|%wQQ2bUOfAndiKGkz{ZuB`;Sm8g=OQ={){uFh5_bm+}p)z4NuIvNC=0 zbYAyvh@VcmcXfufrBIyO-W5|q)hQ{@{G0v!5sSOVXX~{E?ZH#iC#P!D)KkUHvK&*~ z@Kz^`$9RVrkMR=G8d<6ytJjtmP=?N}5`yvmsOqeKTTyI7VPy}GaZ!l+x@x-J&%ewb zOd>D6AX&5H(JPK{S9YiX4m)?c(x5asb8^yUpUI&oVPx^dm*^I|!5Zyd4Ce%O591 z4u5a#Bsg=uZD}6Y>Q2i2H>*j`m%rb{@~rnIKHjK(cfhb#7c1EO#`#ozSq+ow3lxd+ z)p)laobWpJi0J8n){T~nixWEsS4*2+>ZixsOtysMJUaMV%))LTU%br(pUYp~&%d%Z zx|w06?D6q zyG&I`=vh9Y2+`pENKg*(=uO8E_NLUxCkIbNcn!d5k_aKrh8JPna76EoVJvdMFEZv< z&OsGdcp-_Rp29o%J1Xu4@!?!4Qba1r17_G}x&dA!4ABT^Y5$do{C*GbB-K|zlf^NzX{Vmutj*hOJF5Of#^gE&A0DHs>{y(sEtLHK z30FQTg6rFq8y)BI`($Gp>6#yp?{wQ6Vb3TpUus~Auj8b31Hh^4565sN%2e^F4_;Jf z)K^(VI((x~C$1Y(PU}Rzp5x?a__;xQLeZ;h0IanCi4dgcgQ6PCU|Tj z7#F2i9nG)4vg?SirAu&^&`IxDZ71Km(lmq82Z==0RzB6&{1oTS0Eb?jFTv;LKkDa? zBzobv?Uvf5qxF_zC$)lK`rU5rnEpIJ{XK3vl04-=IFo`u-^aaD1s6>LDo-*9Cu)c* zxmz6iDicJ-6*xYHNi-@>c~6E;e9vU(;9RN9@@z-8?+Y9m;IU=kexaW}=C;4XM|{R3 z_)*mB#ZLZ?GoB8wX?df!N5mnfqqmpNhS%B9=5lqWvNT(oDpgOg9GtuH$uK8EuC9C^ z!VdrOUMZy9{I~k~BhnX-^L;PSoodwNN|3p^$qX0(TR=_uDwvv7xB=@y~f>8Ga^ir{zn zh$~JB0w<;V!3MPGdb4I>hDL_Ahp1fX9}$e~F)-w(SK! zini+z9ozoG_*!nZe5@?rlXP0&qu@}|)^C>{wf@~s&8Q9cIAJ_?(}Ji=Ux@z}tW0&; z*of=?dN7(YDp4{o^(E7>?NSZrMEWuxX(Y~E2~$_3p{b*$dU>0?L-)JeLBx7*o1F6I zM$uc4F#COe_IR5|OpP6D*!3<7C}((#GHiBKmho^&!!YCB(}}U=chZ^U7t%23MW*@{ zh;&R<$EN6JLMeb(`uKj*o$)dKRet)1;^~yX!_SA~=@0nnaRL97n;%&}!Z2ML;prXi zczz8-Zej#jj|Tw`pB?4a-TV;aLq5h9$xZp`Es}e+pWY(5qMzPV$qh#a6+}E)$HS`Y ztnoC!k>Qcbbr zcD5oRDRK2tem&T46=bx!u$@Ym@hWijHGiV70(4}M>IA7n{sJ44j(jP8HqbGEQ*OC| z#?5_~aB4OC!o9PeEvLH~VI69F*&|s=bfGq@+QY6nVAGL9u8#eW%M|yu5~8R;c3+o_J$N zHObjalWy6DUpC6SNp7Ev$F5l>QD5>g#Ho85f2=h(i7vd91 z6};a)RmK0D%WJ;a_Li5zn2R!ZsXXR{@%WId736|<_uTxib;5W|&DH31xjGBOL-R=& zx51|n=hAtd6UJj|I@>`4mtY&EV>P@9Co_8#Zy|TuNAC@)uj}U0;%_z%`OQ$@$zRG}g zeFH#AG5kg+jK^$BZDKC) z>4b81skY?movUX*;$v@V__zD%Ytr!V@M)%Q_;>o{ZgnM&I?GIo5`CASFH(>_`mR6|2=;G4P;PNhv`4+gz*?LHf(O^BgSpI z_xib8n(lpmdOw>^l$teozfaR^0wg6Wzs93(@lF_ZvLEyDuDX-`xPy;;|AZ69W42C) ze{rvur#V~z&04D#C$+VXfzwU9!7Z^eUh9$%#M zlK|y|;SV`sJf@byW}2Gi+tn!QkwUOV1RqAElE$Ma0)(ZC@D)!qllUpbbto4f6xu4( zM|?c1R;Z6U_$bPscEWhfCdx*wQLIeaiHeFqe4vU?vLv1)KjxEcIe+-LpWd#@uXeS~ z5%oLVc%bq`jj+e3mQx?e-9+#y;-_=xCJ1_}eOUu=hyzg>Mh4$KZedK#kb z;Q87+*$$roICLW`jveay(oBQjK=QhClwok(B*;g!i0Nm1OmREl?SEsXCo2$_lb`j= z3tmk}(yzG^N7$=TyReoge?JG%nlk)JCyd8#Egn^T*8(oYH@JkF!U#ND=BH`y zYeV>+mXP+(1C$r0>!kleXSZc>s(7MU#(8hWHi2T(6{n2YD6D=9m0$3w+~xKOhx%qW z9z_(tN?3Fg@h$j&(Z?Uv!g+h(guJJRd~Qp8$}g9RK8h+|E&P1i$LrM>NnX9!3ZL=w zNBrmI`UZ}E(7=_Y`6}mAR9L)tXf8jZoYp6f7vZ!cp72jTJ_~T#BhL4z+djJbsk>3qs!abva=IQZNj_vz ztvODq!TpT&<60HjwJ#!*$_tMj?ONR%9Ya5jxk`!mQh`0305=YRIqp z`5$yO1W7F#^(8-lyV2(oS60fO!`HH=mFG&8MR(|Ma&;V=6R^IKR5c!to+vMI_F?6l z=EqCLS$tr;TASvU8H(vO8L!yI`}g0KzbSvp{oeTAyY`*lzn=u)+;QFEy(2HrY{Lt` z1K5$9%lGd;C7-hd{d|5?D`(Yx+$f`SHKbiwWkt>TGQi>A(;O#0Zi77yAsro|#<=5Z zKXb--Pf#TIYXAqac2n(!pLA6ysr;||F%(y!|cE5XYbga z-97^EtCvb>6kpfJ!aRE0+SMd-@LN6yDj;oHsUWgw*z>hzk?iFg#5Oer`)wA4L-;Wb z<5@mLwH1C2um!LSK*zKV#+R8Z%QFsnH%R^_0&tA8z|Wb9ZFCLVj?!a^|G0rNCzTKK zegPmYAI#rFK3=PQu)bONVE!KRA@fYic_V-_bmh2FrWpwdiJv|o7Pe@X+Ax2wYLi4) zHHA_mf9!jRll4xo=qkQ6^hXSRnUnR9zTg8NuT!lW1)U^*5G_5&_A-$J<-+_uVryOopj58{knS@8&jhevGmZ{8Ali2#k0K$q;QVB6Q514mfuWmlcKIs zk7AoCkGZCyOZi*KL>FbE@z5UBy+L(@`jCPzu@G!`=I<3>Dd=p|j&V;cZ+xmo3K z9>OX3@$&ad4&=vlj{%v%F}%~px!tDaeemUd-z=;Xb+1^52xUb=md^(uEboakOrEmv zW%KrAsurhf#Vg%M2agNEAL9x7-FW+*4r8YHO%C(4{QV8BSX_XP{m9xk~?6S6R#P7wxi+a9Q+l^yvmijWk@|kNQ0JoZUz7*wC z&_AmDGJh}WQzxirc|dACv)>TO!Z-2vif_m}lE-e~CI5Q>S@>c8UhzZvm#3pI*C{lA zFX>+f`ow!BAl{BGW7hIFOj3v}VwtFW#WI>O!h3~f{c8AG_+kED@e`*@5rRhnHIaJ} zR?+HMrQc97LzH|k#XRb_QP?I)jIMO7B0k!0`rKJmhIDM`_+6U0ua)PT9e%AIl zfQ}Q?2LNR9WdJ&+t0bOf!ZM*nytfqI+(aUrO3#GMuU6WL%VfxvZ}OZpu+f-tAw{D= zUfqFi7-81`8UT2c<6*_eyu`;ArX%maE%(Wlzc}61${Xb) z{5;%7SdJ=4?+_phf6U)2{z!ikKz{-NzTTx1j3WrA;450pGJmi5Nqe`Rf3{E7##vp6&2lhP9_ z!%YN|T_!yM-XB+ad>`0I}_xFD0RJVFL|4r?L|JsTmY<@SM+sznWiZrye zoPx(W==e=0B|ZuSG!c5eg+xi*9d<~ZOmlY`#N?YdT7Em?;^lRhf_SO`x@`b5NL;T0 z(9xuFxFhbDoA8HKHSR@NX~dU1Dj@nw3y*?NcUJB*VYzM-7mW8=r+8xQ4!5djzjiL- z)1R?jpHg&GG*v_BLu!Eu@TuhJZCIvA24GvP&J%f$!9-|ua0RURs*tDvep zX?oWyP_|v~YWJBfrJJQ=z0%O>OUHVZ!5ww1`w>Q|fq%>q<|IDWH_B^-f9b57=0ndh1az`-snWTroZvgBjh;P|Lc#O4rA z!B@05#QeSDD+S$Xe|e4RM(xl`x|Dy($p5ER{>L2o@5Hm}1>5>KfQ}bQdH0a>Lh20l zXODg6gqY8~*TTs%C-HPFKLQ|4;z3yVq_-*UvWb^tT%^n0Vr|=I;*X^rVd{c(-yM*U)q=|*;7jp;^b z8f#29+B51UUFiSEwO>7qevv}IBRymOHSAYWd-swq>i-F?|9raoM|Oqz*RcLk`}dMA z$ASugehr}QpJmp)fO3%I&r*(Bei+Xjw{(-~Dm>F6pNtcv_lODq9LuR3hnol_yG(Xk z@r^c*lzFe}ta$phSFXC1WjOi)(|(_R626x2AeZR%NtV<4l)q2rJxHjfWgxx+*!^uA11fcATC==yvgpuuCR=#$ply|gTpdC_P za!td?O684mpGiqSdatF&^go+Kf3K;Q=n)4kw#5$u;`O%K=w+3=e5_0HUEVa9NUIZ= zTz&t|R2S9htHGA5(`RDbVNH5 z>%Wq5^i77BRga@@Hh40Rqb#R7m}?>cx6-~Gm*Lquj#B2mss)duT)F=_mMYl7U3^yN2eyL;pJ)lGwG2wo>Jxz_wQ zQ{7aSmxE2WZ(W8k`xJf3nSG6QOaJw?{t?59&{CLaYG{g5hO+9X1i{YE5$~Ad3Uo>&SKu26OpQQV46PD8) z#BU&d#=pnJe^J9fim>vv65IA(gKyQg?R^GMX4}Scs)xBI0&tXrg-m+4UThm>-m5w* zo_^c5G=2E}rrr9|hqay;HbDeVb;N|sFZ&XK{i_pbKKhQ!q-)AgA8e=edF|6W)upYW zW4*~Y{AjC=Qzhjm*F*qLs?8cd|s z2~4iO|7NO-wjIX+cbvHlVYVIpl}@eQF^We_Y=<8QpxvUW@=qWfw}qXj%HE&QDEl2$ zFFLIt>9`84RP~f@mf`sWrt01_iXtcI;V-)mRcH@@&ujudbNHnrzcd#Vn_Ww zAE#!-opdVfc4?jpQxAU<0C`1S`a=k(?$WV;RMNVo>CdFA?UQRF0LT7eVMQ{{(w{$U zXnFm)1K-j=DKD1m72k@d-~BI(Tz)E>T%uD`mecy=nh3zHv^^D1ALQaK7dy0fH09}~ zoa>bBdS!w9nAc0$HKTx{t zzpRJO!!N@#<<2nc!MQl~a1VfUaq_9pcoh0-AAZJ!WnLb)3;O4E;8$LpV|{+s>Janczsb9mKL{YER`y>95tgpz10M=m+v7Ks|DOkrEPOD3ulPtoH@d{%OS+KTZ)*L2(WyWC82c&vBV~IV zfR25YVYU<7?o%c#ZG(7k?lRIuA{_G*VlGoVk=8E&Xw$xD5Zz6_$&U@+6AKG3NRLjR zSwA}FS6(~dlR7#0yW#sSmE&iCKSg^+`po=ms7KNIXpQMc>yKX2rCxm6w5N=34F3{9 z<-d~Sk6$+Uew*#7c&@^8()ha@@f^1}4zo`%%<+q1>K4Q7OAK>u$MBd9cUu25|2CVS z^J#`@Q(3;^-BLhU-UW!{YW2rOh4_qG3p0Brk{2{Ewbl5 zrl0nxAbL5g$MgkniuS*mddmLVWBP(O1^uIaqAz$;&@c3fzTnmVd{q+yK095e@n7Ys z$0xdeP~Y9d-;Mgx?p+Pw_`L_fxcK^lakSCQM+e&_Hkvy5c@vhGzZm|435#t*zK^i& z;L8hJ@Q*XBGQX&afaAzRH*m6dd(0#^y66Mk(M9cMU3QH})0QFdPh=z2i^ zG0yvdllgxK?}JY)$8lWw&ovQ%bL5zbPw*q_K=`9qEVwV|}PU zZh7X9^T&J^GVvFuyBB!qh>LY5zh45x=^;v8CVIs8D*)h+bo|#$Sah4|Uj}rTAIIn0 z|AKM^uhD#)_~`6>Thcq=lXhWU?R>r)zOQJz{RYaY{5VH*=V_NAOq`rQvHf-fsFzm( z=qO+E#QOfG3BQqeRbTZ_K)V0Uta6||AwhG#svMJ2yd|yHkfTg3iTr2elUABH{v-B+>Cq#EvJ3~aqZywNK1kjAYS2xcuoV{g&}A;^>0U9JGcXBNpKh9 z6<&#T!E2F5&^o253-g?^z;dTk!Ve;!LN^(_0eM#nZ$a5K@FU2l z(2bwBBkxL}8(v=0O#|;kzD~dkcD;ZP0#6d~Rte$54txa9D}j%r9KprK=XSP=@r4e+ z6Q6eQNu-@=_+{|W4Zesxo#0DISLoE&nfB!l@S8|e_-#D9@GlTn_zIpo!S5hF4*v>q z3crWvPVoCkPl7*0d{+2llu3gBfOx`xbU@?i|5-}-FUY6xbv&nm{|EUL{sPaP;QvLs z!e8UL8~iQu5dJ?0G>-n?cY*I9UE!N}wvc5W&AhxBv0*35Zw71w~x{5@N|fr8@MZ~0KV&#`oFwD}azvo+u64Zd-kZtDkmaBiOmKt2M4*5Bax zjMI4LV_FhuKK0{yG@gD8Kig*z?ISBz{SVE-!&uIYA#(6qeYn2OvT}H?IMb-rk@tH5 z)3}@-!4=fM--Z|R@=!R@G=3!(p1xOFp-{BKoBg&Cp8AhG*EDL}KW*{7?s0?nlnuZ1 zQzrjCe{1}^f7jrDXxR9RPni6R;tdp*Z1|)Nzw~i=C_J>&@Nu6lzw|8=Kb<#z{f}(E zg829`a=5=K;ez`275s4N2@`&mjjw*xggKRlE8O?E@gIu$b4?Q;_sbtO@vnKp_?5?v z|B|NhZx?T%@REWFzry;{kDIXi%7^l&rQYgoD5Z_<%y8Nw&|vYPZY*%`tYvTe&g29>?(|XMji@V-+bwp?*5xM7q&mJ_aDCUt_NED z(RWEgA?}YX5b-00QDJYOFh(*T|5{-OkX`zvdkQ;=_0lgDc97a@zfss~^(~@r`PpjA zDW6*YJX?O7u(dD3vxQvl{l~%88R3md*vAJFxBE+{J|pil)AUroKo2$<*)Y|FQDjVENc$>$O>$ z<5Xdr)|b`$hp!&}o~_5AG|%p%|NF?%*Ztjlju*x(o?%;F`5!j?L~=N|WaKol(X{X6 zhfMn(vhAkvhp#v7^lU4S!?r%x{-x=^lXn?LsyrbD2Bb%X!u#o5`Z z#YV9)RVhxFD&xeuxHLastYbF8lH9PCO>2uO5>NalAHbQKXiF!@{lg+R{R-Jc1sX?OMHC zij~R>t0$NafO{Uqsbb}g8ChSb&xT>mF49&_)WQwR3Yq-aH#K!tw%xO+vi@^D)p|A0 zzBo3`)T)hgb*Z+b-D&eou~9l!gB}%C{Z|~-ioI7co87Nx8F3^<^{_507D8_d`pvdc zEQ{5HSfF&Gqz$*R(mp`bl#HOaDeXD%Qaqww%8CQN$dZSj{JMicKYs9fQ)K)G;I_;i8b5?WljBDWbBD&SJ)&tBO*QV5kz0NTnM5#g!-F8!$_RCHeM!PeKHTkmJaJU9*JsX!cV0f z$Coo}PzGtaI>P}u+oX%*d&@lTugtg~O`mi|%a0C~i_?{oWq0`_M27v*dhOAv#>oXu zA47gKSF;5?i#jY*xr1OC)3qV)U1BaNbBr-Ovnu_j%cYr_U@os5IP+KM@-RG8sy0eG z3r-)(RZ4R@&(>0Y?S_vvZoF}RR<&l8As_duTkQP(`)@g3tYZTbGvLKWd1n89%jl;4 z`|rx%ls`0y7@z3Ki%*p5m`vJ?JqenH1{*8i2DlLEl+Jy!;iKQeFI-yRbc9~^t$&X7 ztubx)nObFOzG_3c%95eY}njj2e27SC|KG+#Sm7obrkSt(s|En6xRJ0N4<#dnrw%f)Jb@7-p! zy8F<+=j0K*k|y6PZo9PElcIqkP)gR=^h#1gP2iM~SA^dpF<(fdbG2HdT5G7DB}-?d zURtOWXEal*u-NBR18BtQG_1bW2&prYdsSbHDypZB7k)i+7?pGp)`vQ49ch2)G<-(u z9IvOhU|C^9bKguW7xVkopwV2$>)l(5)6@0RiE^<~uBpL_*J;^eaWf;{Hp+gVEmh81 zn4z+c?wc2DOZA!3RM&3T+Rs=IYiF(I23Q+U*%ZUbBTKc#rMjA_5t3Z06ix1p*vJ~@W+mv4 z(I-}5+T=WMw$EFvzm-1nYhHPUndR69IxyI7Wiq)5BlG3OMT|cd2k{W7hr~gL_Vj8J z>3XWoQWkBQw}S-ZBYPO3^tz8{535rcDrZWIU6~nB4Hb#dRPtH%* zDqYyL?4CI`N9N`mQ*%qzE_~X4d-ZDG ztx@!JZT6%^__Qc8c@~*8{3O`*&93RQI|AkEELM@0&SvV0+6lYyDh}%$Ig90o9Azq1tq+Dp*d-yqTpfbC=r^ zWO|SDEHAIvJn|wTm`=9N<+);&7fr~H%l%NbmJmB!tUOvgX)Pg%%3FGFxsjJwAFkFO zMXzD9yhP|GkDj_q+ViwYmw%Rv2~?y&c63a`Vs;drsSgvOVHCtF|no0WF; z)#16d!W%FJPN;Eiri4{`Byf4#7RXO%Q?W64!QpWLhOVKnz~2J62tbXy3c$*6YQi{< z9M1&cj7ZWLuW7(5X}mDPa=f6SY25E&Io@4k8ik{2q<0yB%Xj+Q0nEdp^cet_JJ0&( z!`}^{*<$=I8)h9?h5}Z+7vh+_UdjXW|egMrid3hFqI1d1rcN{<-co~9a zt^p7)aSZ{e?Ua$yn7}j39kMAwg-`deFc2gRbCDxo;-l~9{@1?Ab@yZ1yFns;hA|} zZT%vA=A8yG?-YPM%mB0u_fA;m7=U@^0Mvow0LrKgb8!oN%IGx!=B-$N-ul#SmVFpN z{M1>+pQes=dliHd1Tp7I4hTjDL3j6$K_@wa$fa3lk zJd>ZdTK{eEiRXs_%=;Dq`5_)Hlcr6ye(yjz;(I56blzpd?}ktOZwIUd?~htM@3nZ| z(*e)>ZJzhR*EUxEejIV+kM$#eKViei&lS8vq}M zt~>#sy7E&1;#0aGwc($({>R{x52f=FJX7urQ|G<`-?bM<5hlJQd!=d5Lpu2?0F>uX z;F;xq7QnQh0chIK;hAYa4lkU|8Gm7j5`W@R|N88z!#|f7*tr_Y8l=h99)y z&)Tr+z$Xz_9)8K@`JDAX51)MgGC=cu!KVF+^?wyU^L!CNndJeRS9P^hfB!Y)C!fC# zAf7J+i03x|is!fR%(UMIFzs=GrYQ~WpI=29^L_=O`t~nv-0#3=`QHV!EB~);-rs|- z<^PS1`+cX}AK;mM|62gthd3GjcQ*Vc_~hdc0ZQwS@XS2_9>BCe2HXT-+1mks0{BzF z%>c$}xv$}w<^GfP|J?fj89wp+86aM-|7!F6H|swEpL|l6S?22imiZHK#*lg?jS z|9`+|-oF62d7qB(UjcRj9tZ3J5cl5z*f0MYz-Bel{|R8dTzcO^nDqXa^}h|D z^!^^;(jy&~8wC6#U>NW{0Nia);%5lJ@OJ=oPWq!vr(?RCkGPzCkGXh|B&#_1E#-*A zDR(k$Ioc$r+-uX8W7}vs)^DQ|#-n@zRO^MXe1+rxviBxnb{$okU`l#QWlFLnu(5Hu zu%0YzWMc^}mRGPITiK>;fw8eE7AL99l$4O0bFnRC!3DE}F^k#EVuM-CW)@>GyD`<( zH8sUd)pT`NO-~QwqNi%QYniSZsQS9QzQ*(aC*s_UxbMFA?tS@QN|~JazVqV7jfitj zoH%jfMBKRd1?i)C?MFFjAIixJm3T=*>EJSwYoq%pC-o6)f2h1&A)M>iFEuZ1uoMb!=qf(ClH9yk&5#dUO|xOiouv#;0bF z>~PfIs9bGAS~oW@d)W-JV>hcRCoN}jbae1o6+5fd@yY3t>MYi$)yWCv;J}e%RXra- zv<%90R_WRJpppAC!cwJ>`V`8#xO~F$TA%qezG3>LAdSnca_-2`dy_UlgHM%A zXWJX$XZe%k@^^&%AuCey(}H8Z+o9T*>Xw;|8~LsVYD6p(MW}k3)~1k! zQvhXHeo9>atr?cJiErb5;^({(;NOrbA2o4xxKX8yheL6G!zwR#e&Y%>TQ;1IXuw#V zZag*4*M=!x*%VVcD$oF5oo<{Sehcn~+Y(L2EBZ>%riZ{Sl*AJUxeA#{w ze2Rzis>bEp>jxh30v_Pifg16Rtd{cK67!LjZ-g)8|E#!PoqV^(`C0kOPAiH;@}*p! z9@optQR;VLq~&(hvHlZW6g5#+&WG z_l9)H$KJU7U12`5atDm|Kk{4Z(}e;4fbX^k_(cIeT*}`oDnD$`#c{s;ZKCEQD{4Q| zkp-MTEzO)*_lWxvK+uL##wEa~eXDV#SrtJ#KbwnqXPmPsd%Iosxe2I>S<@d$q z@232eU*f9;Xf5oPeAKnA$1Q`p~)^NT91;78R)3j484 zpGJnR&f9e_en!d~5eNvWvPSvnbUE`7ez=3( zA36ltN}3LB=*w|4=>4V=Y-QUhoZpM_)d}wvaekffUK!`t3GY>Len*8@@wOTyB4KM9 za+A@?cD@==RBo;90x{kcW2}?hK%8GEx!1(`b&?y5^E)cJ-qg~8NUrSkzFHi%_y8b~ z;WeS+Gk++~e@!-jIL^;*(>1lE0o|*zc)1%FBvno@KH9t3283i&Z^jM)u`5I-*Kx3%*sVj#7LA_6B`}A;}-*k0Ie4}ys4Iw^c z$(FOyM>_XWG49v#`C8ly`238=D?4<^(w#c>c_juN=?~;qwB#@~;olxNJrD%OTyc{YL{l#Cv;?E`awdjqo0e@kDb7>AWG%@7PWn z(8}0DtU4(+jx^s0P?_WMtD%gMj%*=hw3+#=mjHr#S7z!(FYBPF(tVKS5Y*Ov&8PJ_ zsr(xy@xKWW;BU0%`?{|$_=%Wfm?1l-yczctAMxK2q;c6wSH2O_33cTyF`l|UeQTV* zD1G|2m}cQVeS2K*o0&GZ>bvYbmGE09PZwUJsS%v&<$Sv}lQBU{@b@Sr^9n$?okj7=J z_I{^mdp{ZDjoOPWX%AxMFP&RI)x2JIZf&S1_r`b@tS9#c_$aqe2WecklG`KAW zK!*iMS^37L?n4NFZ0EP~^Y8U|r5uVV-oyUB?8oSRjloZ9Paek2fNoQJ68)3z zyjdaI=o!hO+4OVf%oConF?dLI;@h|mcxb5;--*k=nr#j0*XhtBaegD)eukHs%246} z@1x9DzJvQs=enHocZ7I=G7{by;WN&e+38E&XJNKaOdjCY3ef3e?x@=7?kko@XJ(I# z;j>(G;|E5jx9vaon0(ZdG{UuazwgXo)aR#ROF{|%D5j_q(4LYOpopfUSn(h` zDz^d~kfirZRzyJhHcjI?{ZHizuGa%j0WdIcm5ar*V}0H`3AX_~l>|Qsyyt|e?#LQLrcoBCosd=a)Z=4b@d4CE(@FH%-2g`Sm4|#)?e6YP`_+a@C z@*y4?`B)903`04trbjuGlkudf=}CNkZDwF*WNd{0^2I{L!X7Qt8kX-=Yx3x-rci3+ zk7Et@WZv%-UBy>~{u)PL{EQCL7kuF3b{%DXpp(ZBZp+B=qfF#Lxv+c(`8h^Dvh{>>J21{ z-b}PN*CDOa+=y%1s?%H<`Kk(g^DF?RdJceee;e>L0LL}&F#xB$QBIzT1L<`9qxb8_ z|M1k<5k4}b1PJ<)^_sbfL;g=%lrPe5WkZ?YDJ@ex8xtT!2;`l6?Ml`Cmg<`VZB0iM z`%HPPB#tiS@1Yc3)Jf;VwGPLdRX3;)1^5yR!G34?PVrTMZYqyX(q%g~03a7xfie9g zKmmTD@|}_c>AT_KJT|6J_V>bJQ}?3e{7d0wSSRXEu?`W+3WF>^8Gy9BK*=rIDe=;eW&Bh? zwgEXluIvtI`7A%^h_-A6@o{co{96DOkecpRFP|&l^a#RvhI0vJ6wW2u5oh2&_?4H_ zwSJTNAZ<76b*kNpr!N80=Amr=ru?1`ylCe;)b?_YEz@3>S3WBV5(o?F=QB~i0Dak& zqCT*EC+Slsh_?zTtY`k^`Z9bIf2a6{yi<8>243>N1yF_`mhTilq`$QoeL10_>8eZ- zm!gaE@_1A6txuHw!f{!8(hkrSIa7|$0u+(=PLxwVD+v;DD8)yXUXHxwagg$trMpmh zqkf8i2ik$OJbEC#J%BR&v3#faBmLa~#=8LE>n_#1y+{|}D_zX8e5d#-KsQ|kFEZV9 zTy~N!|AKyxJktN7Xg4*j(n*+8{s(%Woa+-@LcTh$k8yx z)5LD2?O?r5=|gsM3qNF`G}a~{SS++Jhee+w7fUWpbRo5Q)Me$Tk|2Qq znJAR%59;=_0a=|`JvTc#Hj|UF*8S())%X|ya#{T{Kp9nL`A)H4fNmRA9MklxdEGzPhP_@+KV*tya0ePUwFCmLX^+S5w|py zGTF+16FF9&0A}SgOBZ~%HC3SAVlQ{39iaOmwg<6%)`ji50#HT{EZ-?PC|&A8s6U~e z(ETHyR|3HIN6Ej^?@f@%52f?~c;$08r1Luf##aH9zlG@ci+~6C3+wmqqP(`Rk{}U> zQteXyo9MTkzGr*MXO=GbUMl)6?a=lvq`$6qZ7$qj*W}0zw={IRzvOLN_80kF!u^%D zV?Wx_iGF)A@RS*6FUgS~ZfWRrziridgnTaHeoNc&QnVxMlb(8TbZl&((Z=qzsL`mW zxzJw;P;Y)St{Zs_*C7u*eFr6)<)G;oW0ZIwD$+#g@fH##@o?H9aSpTV0U#!y_R#tp zaW7k6cPWTx0>H2VKn98HwEza1R8Duq{W6#Sq^iaZNGpx(az_QkSZU!>@afLVjV>+6 zZL)&t4^L2MGc%{KRXw}4bCD$lF@nIYt4%bRk?E%W&`G+K|A>?Sr&a!k0{Nee zYt;+(^LKsM=2n2OX=_}}cMtS67qJW;HkHA@8+fYf6K+rZIF2zRyy6K+M zBGXOB<08{d$HgMkP3^!U(@mdgEHd46hq5t>mxOyGNMFIUz^^D~gaa^VS-ATG= z|7W%Rr3*H1$Rr~)%NuR0o%tpm~Gk$*bLx&%z2lA_c<@K ztm zIK(&Lv9}q1tC=-!0jNaQ;yUbc-B#3Hmrw(A%kDPR0cSUn6UB2z2G3bY)3abqX%Y{m z%#;4aOOot6&nhjxtNP}rMglX=(GR=M3u%Uc?iw!#p2pf7k(uEtk z5p5h88k`+DG&wywG&qL3+TL~);F#lO!ADfy;P8|_qQZJQ3@Zr|2#}3JsUeq@;qf@4 z!T~~k$XQ0F(-vjksWvN~Ztaz;Zk3si-st-8t4|=-`c34LzCOu%+MY^+1VX#Ipm_Qc zLDTG~l#YQP;aA&58^Qk8Y4&Vfhhv_GlVd&spzf8FiSo9FHyektd~Gf$?{v99JEXi+ z630lp@N@g_jF-M$#3vT~OXWGTL_iNi!%&A^rF z`fsVWs7^lvY=t^~JmyW#qqOIn0h~9(F?BN1?8i3)pm(Xma0k-aIiR7#AoJ+(=+NQG z*~#(Axf#^e_O~;SzQysf;Cb||4o~TMl=V~xD+v+^?T+QF3{TW~lrryBn-$NAG>^W` z^`Zdc6CAVbbB7{1&^W43CFw6p>KEX_$KYV^3|IlksnIgKFFu^{7L(x zd{h$0M7wfEz0&h%hw10epE-VPy8YH+`hr(&u=feU({&fo7s zIy?6?oWD27I(Twoc64HH;nVlK9V-i-zTe~Ul%Bp>uT!QZE5Z|X`lie~)n>(WB2C|S zI$bC|eY2jnr;;Fn(C)ONc={4S)9j~|X#qdcGPua}{a)9OD;8t=rl|@|9?cg`Tc`B}1pVJ>@e;B~Pe0}Q6B|mWxH`~vcrjj(cC%Of|r4&u=^#BIq zqWL7<_qnt@&B6Uuq|f{BclRIG^aqeuzS>!ue9+-rux-2B;VEs~SWoq^k|2RVId~|g zcT2^#QRba$v*PKtZ7VW{KjiwYD`QyOd1?Y82&yA4<$gJq2pnI{K+7=>LMdHSe!5^g zWz6fCR#%s{hJo!S--y$#I=V{APbEPDLFI$ERJ%|p%uKem9#}424v~_VvNet zja==miNi!%&A^rF`fsVWXy0)T2Cppovm-O8s_ZvWz4U1XNoQ4{UDZ>%Wv1tkxu!>M6h%(Zhrb*;RG}>ZUb72$ z&FPnc{L)-dl=ryw22QWIpL@`1eS*w#p_KZlJiB08itb{hhom~$zmTWk)%Km1I3YG0 z-pp$=l#;pX-ewT%^pK_NN7szF^PUQaLz+*8sfQm2KwjyP{shv6hx9tGeoK8>Gab*Q ztNl|+kU-%0@X(e_%Z%qwI$F_qZeoXId{SPl*D1agPq)Wk8M%C_oLthUrmUy!sU%1s zwA-JGrwek4mWxgLJ9T+Fsi%-fVVCD#$WP@^Nsx#`sqq22k;}6=amc!44`WX2Q>A!U zdr5m$)?SA8j!R;W-}?ZNM{4grjdVGCH#<2yI5seWddgc9Jxc8z>1O*AeCQY{B@@N7 zF#!UEHv6#@O>HaZm9QT;=aBwZ0OuY0JfYmx-}wygqrHV+D8C=&wVjm&i8z$v9dx4) zO{_~|WGzyqXerNUcp7c?O$(OlvPr3`2`;q-g-46S+7io^8&jKJ<`P(SP z*JK>X-=Aqcl~E-D5`=cgfzsvpWjoXlKMU8CJJW0jeR1mH765&5@~PLj6#8l(KIhWn zmuKyQ{_Pw1l^5sOp3l4T(mrk1rUW;00_iq_Oz~3vsr)GY#acIXYbyxtIr9k!gz}y9 z@dJpn{c+0F^ytJak6R85O->At&hlSqeEBaRR{dzAmnj{VSNT;EBoM%dLfQWKf%5-F z;3&ff%Xf;80(8?u{GFr=x&2Vv|K*_l9Ag}(9FLUkRR9K#Ri@cb?DMaTsD!}N>pr=|A1!}N>M(u5TcH0hr=D`W zc9_24EkJ)?m*@-L0`zNLqAz%LJfD+5z$a!XHUFzT_3??WA2bg4@HeBqw0qA0aQ@x` z;Jxhng7;{nS&jj=OKdcC@*$U&m%o_)mP?CmL%Dm|cZlVMEyRbJR+*ocAQ1%e&EPpKLp%i~vy4!$!hP^6+J;zqTV>Fn zAhUHSB^UPS_W_>9%EuB%fIMb_JT?M)?~Q;Sd?Nr|(ryTy&`ZS$|+og>pZvw_Z2S1brHB6j|JKpdO@X!h#Mww>t2=W!0 zjdkXIw+Z|Zc?v(qbqGH}TH!HVH-q0teir^U?kW5suA9LhAwLg(hWlmVPf;fi{tfOE z{#^iikMUm=g#UnY3O~nn5%`ZNr|?&}ZU+Ae`3ir7>sIi0C`0%!0q8x(|JVY4g?xoy z;MzkOKbmEEGGf)qsJ{-d0Z^^&#V-KT#H;hx(0j1XV! z^R>K`Lb+YO{!X92>uQH@hfhD<=WD#(->*3YwaYdAOSw_on>hZSB~edJ@to)RP`a0S zI+yx#isxBc?jeV7htK!zgFNWlR{@ZZzzQF)3S!>V`z*)2JkW9)XUph)#u@zVpB3mI zS+VMWXs);b%b9-MTyddZT-;z;*?VwsXm)ZMWq%EDolEx!p{DUGeR`@Y7qwdw7msDq z2X2sFs117I4gb;!Pve`P?K(9ZAM^Nbf7IbU>eJVK#g%{Q-?{kOKXCYO>UHtVEiWq-z@ASc}smkGu3M z{QZghT$-*lLhZ&!U3^m}KA5=s*?9CmcmK7IyLjwT7r!KN@rxwtslBA;(l7V%fk$0h zW938n)A~2~a|A%guVZywc?()5&3@h;L6#;|=T%4EDbJ|9tIpraoKi_xZi2 zy#6n*c<_{3|ATT-JL#=wK635fzO}aTRonjQvAbSX7x&#I8MSP@W{QY!uJs9fJ+*$4 zx&O~=n}F=hM_yVxnOM(!q_&CFUjLW1lf1sA^gTZ(`FhHy)_;<(zd_hKH^sA_TyFd4 z+ImlClj9?mL&fK>@qDfH{P%l&>wJ6H`S!2Ze1Bi%l$P`NH%T+DtSP@6*xI$vsXfKh zdCE7pZ@8gydhIELuDvTxK!^?M-=VQHZ*E;ErqqPm%UN-Nae!B11z8x#1 zdp7U;uY331{`c=cTQ8HPB4( znnCYr?C#e8YQDzV61>l#u}itM@}YIJWwdOOxD}2tKXY9-8LssFhUIuKgfK6>ZdHc) z*$L85iuse_9-RZzSrOh#t`8JVhH0ZJAV^Rq$pEi;Pnp#+A!B+^>uNpL4eROs@ZM^a z>2>9zM)hi2cIm}#y{KXf6{N>u=!P&tb2d4+eM}Ps|4I3zj1L*1ablPCu=#L&uNwJmme9>p(0dv4@ z0^F(e=7qAVOP7&=LSc2|S~@`gZ=Id7Jg!&HD_-7Js*EdhuEHS@jE4Eka5OZ!o*yN7 zSK-KMbiFbiQF&M4C~I`xpdqc)woH@CFyDyH+`h``mqO#BfIc@6%Y6SfD9}o7`SzfZ zG>hENQ=R7b8udq!`*~{C{9dCTEpk7%*Yn2e{Jk8V$Q!@&_X=rDBdc0KlX&Pn&th)e zv4aPn{o5!zxR<~=UOAj%;$?k|^=^@4-$rnYv z+gsebZ#wc$Si}wWc%d9GJ;V+5c%hC%XhLg*3rI{TVi_y;C6q?zQwivSg zO`(aMr)bh#4B7ss(8LbiqRaL-g(h}B7hSf?oTfao@c!`JTN088DN@C){!-va|ib zu`JGUU6V%dHQ^k$@>)Iex$@dQYPpt7i48XlPLB>A7#pcx9ZYcZcc0&Irpqrge>Wdr z{@svDD-6FWW#bujUMj8I-+s-${gXSYn4fo~Q*!kh%*XR!_fJl2kC&_cXJ<>D zom0wi*GtZ1Vlp}2V@Dhdf9z2X_VZyBUntchkX2mseX|w&_!_SZn#VV;^ty^`SMHBp zp&*a<>&x+#UKccPBa(Vu#kIrtb5|(HTOV9kaqY_e1+H9B9DH3vudBFr<$m843i67! zgRdFXEHF;gS#%h!@aka zru|FBY5MRx`NGycY5Jyfgdps6(T!PX1G0K}h zh)(bO2Tew04M!|HlgEiE5AUB;Ft4747Z7;}Nj_BfFVJcp^57fUxF@>31u^}D(*T?g zp9WwaW6sN)0etn7Y5E6D^Oa7f=?5^)H{6-#w;Gt{Jk2!yBBqI-Y3d8p9Aj0$IRFOI zrD6UR69~jlJ`v7+0zc%(r}guSTX`QrV&p&FrzJ-EY@e1G>2rKqVx*tp(-I@S&8HH>Yi zTY$dka~J3f-U9Sx{B(i7;MH-oCBc9={-Mm+HCya$GVGn%V(6~7|E1>uv&C+1FJOzz z7DLa>7T5Vvw8iJauWRZT(_dW-zqkrIp&v}&IL8luCjHRBFBSh1=~jMhSwFdv-z)SB zjJf0G_bzL{r-0ne@5lJ)f~^z3U;WOfB_Oi+!Te0f9Ja2kEi*q8ax*_Ol|h+tM7i0T zANo^Z?y)t0{(haU`EAYLk$qoV^P4T^`p;}JgfJh<%;&b|_s_`SM~hzrF-jclDP*5@ z*_t0hYVwS)tA0;`v2JUA^pCCid(6+Aw`I2G$C$7+e=37AK7y_J{quwZb5B?2KHYD% z=lpi&3bxG7Ts8MY?aWno{6O&~3fRJB{p@jx+hTjpkFjBEe)pxIM(1iV$D9!78w=PP zTl06v*4uM_$aOQo&i32c{s!+fn4j4l+hcwv8M@AEe~>vO!` zYqI@5*r;xu@hM>YWIfXb`nKjrzpCxE=lu4ZAO4s<=f{|6G6yYdKg?`#%jXVu<|=-hBt@&-u-^AatHGi;1t0YJuEa2Ie_^$kj@+YjBav;7bP z!UFa`%@2e8%oexY^Regr_MBgA1%`{nu)X4+AuX}3`EAW_YyPHt9`-&zjD@|=U&!CE z=lswW-5;wYNFXf0&y_i^Z+Z=eOtlE!TXu|Jof}XwUf} z*ClR??KwaC(ANC6=C?J!t@-)Cq_71&jQQ-AYkWS>W_q^&>Urwen@a}?#@W^eL z7rcLM?~pP+%Khylosp%1WpC4)<`+qrprHm2eON@MZZv<(Hk(Mo8jkIhZYOx#uI}$JYG0w%FGE7(+R>xsk1XCjU#az?kb}xlZd`0lG4Gbeb+~ zt>7&{zpG=d0DYMgy3l@`YoO11zSO?qXW#H^^1SQl@xjlu=lqZZ_AC_2=#f3=xBb@>;@P9E`8)HSt19fk zIRFOQgbjdSF@eDEX8Ctaa&gl`-}Fh5B<}Ha}M_1e#n*Yl-f7^T0UbDo7`y~w6Wh(?)KgO z?$|!_Ga=VZD6>|xHNRi0!SA#+KNQK<{HYAej3dg;_Ftht1$=?7u0w3iZ)^Tj{Deqb z=Krhtc=^5JpLE*aM!QZ3zo)=hw>3X>unYaa6xaOcii>>(~1O(2t9?GtH#lI`y2in{`5sW_uJIKyfIeLp+yYwixoWJqo8pW{b@hdmSiaM>vO@EspIlQ)Ogmw%E>y zt>V5=CBYAZ+2T|NWyTTZW_uLSAKRmlVWdB0bcnWiukBHoUtCF?`j{;?TkLh9j2$t* zSgmgymyw~_V)Kj5FUI((B=|vCz+7a0G2~}{v8a*$m@S4R>>PzV6Q1){piA( zGPA{ytJz{T!xERZ#TVKhh3!#P5~o88@C)sHF+^Cv7RlMkF3bgXz8Laf;^&La7NZaC z9EI6pN?-wVk@>}tUxB&E&KEa6Uu?D*I%Kw(mS{n?$oyi+uYfHwzZi1r!n#0g{1W$z zFS0!fv&EGJ0|a3Kexcc7$j@xCdw2GDeSg_(vAqLLJH~ggVaw#5>;hv_-qr53e^7v~ zJ-b6cbz1J|ciW?YTnp%*?NKz|qcFc1I%Ink5CVev#ib>;0Iv=bCLPQ zke~U*qDJ~-wiuGIcRlP~5B~o_&buyRGi|@vnG1c^RY_cW0dtZ0#ZH9bZy8(M(}$Yt z2WNH+9Uhz>9GV@OMw-u{6!P-(?y>xdcE4F0n&feV2jKzhMdeVo|(z~k0$phE^W0(!T*C=jQ?Y;f=>89Q~d9#od216 zCitc8%>K`m?BU_I#K@QV7io!+7F&U|#7MXLA1cNFWYS~cUJq=P&@V9N`dF{iI#+L84`uuVvu)nS!Pd!|4c#R%(q`KxhDUDm zaxmNG=EMTFby@#^>k_kVwuZ*|g)Nh{4K5`{x|JW;$oAR0au8yZ_g0tn*e_uFYz+oc{zTM`gC{-La&X|@=BX13TVF8oP-zEnn!SjX0wke%6L`-X%YN%C7}4B45h z`8B@z#q)O9o-LJswr0=yi_JyiznWic&z7Jr_H4=7+%j`EZL>XFDrRez^&X7w0ob#p zo}M+(hs^-K3&H2_{XV_cr`P#3pUYPP_T0Q8GTM}X=B&t?QfyEc=5e!a(9Z&Edb4ei zQ=e80tPvDsp?#jqij1V0F7i&Ght z@##*OJr-T#+jIV&p4HH2uJL;TT;rEn^Rql;DfM|yz6uEU05&0=b9P?NI0ffF<%~Mg zvTunhMfWf5*%E}c09$0w`60goexaSYf}FarC$${TT-kd|&<)sbJKGOAG}`xtjkf*Q zVz$=yUm>S1g)+Xny|-lVE%nfUUxCy3eC}tq?Y61uk-GCG^uNuIhJNUpdWk$Yx3lu- zGdn8}At2ZqI+Z~gAAxeSXG_qZ0(%JdY{{N2$=U|$B5}@|+4eKd7B6HjGFxo67!rs= znfctF^V@TNd(MyHQ%UfHuz+=e*<#4g{9;if{V8jU?b#9}m*Xcl`gV$a6A$ug^6iwa zu0acob=fEF!gFNXe?`A9vHe%GZD!lxU)i&z7SGnqwkrO{MItRznt@}WqBtO zexW|s?&BU2((*k@TuO|zoLfU$Vx&bkk(LPbio$cvn9w?*ZB6F-<~bmbN-fRp3D}TE$+r#v>g0m`)(A*2KFfA z>@qGTM%vEy+c)v-n|OX4z{gmMXZy{znQbfb-1vkzFIZrI)1ECspS!T9uoP{ZJzH|N z&7Lhm4w#=6%6zwgb?n&^WLLoU+Os9dsSCDuIjo`07DG4eIX{GeV754wLD{)T{4le{ zE%&qSy`_=crl#}H%9|~Q4KiCSrr2!p{Cs4#7{h|!>9KD`yRp&6Zy6o3_m=Fvr6o1i z3izG2{|ckgg*||!xc_R;mY@sv+}!?e$^LK2{%?tA;(2CyGZc2*v; zX!1Q!JD&;pbiuE(v+|Iuot3xumY@b^iy?yoYh1I%kdxVBj+lAdSxJ~mpX+g7z06)9 z%iD8)$j|&@Q6sa(5QEv`me0BE%oX&c3vk0He0-q zxyWp>*hxKS0%J>TP^amdZL{xU@m={P zWZTHAteX(^oD8@VK!3%+WKc#2Om|FQ%IHg2mfse+)1TYuotYh+9oT899+QM=K~Ec6 z(9_fZ1Omp?(vICZE*k|l3fdV3%Rzh65zO8ERUFZrDcAbBvG10_>CwRhVPR_u%;Kz`+T{b?e~t#OTB! zpIkjMJv}+?6KfC6&I}Aqj?IlvxVPLYekIhiG6B;tNHdwY-&XsYm7&4u;hgK<*#lz( z!v}rNDx{Ru@Zjv=j)T)|gg9N1c=Q11I#!>V8y_E>KH`e4q>swA8RK<;4S;HGFMbiy z_`*MC_*rf5K?$|p5A9*7?LPfu2=~;^XN34-pReVm6w2-L^>_OGT~|ANJAC@-K40VQ z{(j9Ns9mnw)49}_Q#{Yoat}FtJAA%xALPL`U=_f< zY6A8#B<43Mm}bm-dSCDHeipQx#?A7Xr?^m_-MB)ve3kF)6&L8mg?e#uMv=6~dk+o{ z%|aoaBknqP7%7CB#;^40sj6JmZb@7`mPsGDL3*J!=!G}@OD8;yZ+^Dx)NFjr6iQXz@sj$vGSq(Y5f~~xmWpmQ;DmmEy6c#J8uW@dkDW27BNAf4=rPQ=hH%`~2QhUjLU@Ja|g2|3SH^o%Gf-AG!8#-&))F zs%`)D*j=xxi~H`9j9NBcGeyKV*ZPFLo?1W2-2dmbO+a?$BQLF;Osr=p#iY-ym$Ao8nndF1P)2ZM~O3V5Co1__6)|B53Z0*|T)VL*!P z|HI37mFHu%WV-TwFQKV0kgczS((<-gbQ z16G_q?3{CQ+O^vC@9s~y{@vsIP48cDvFoR2d3jtQ&FQIK_}6ay?!MaT(QcpKCASaO zcKQC??aS}_@9gNKwOxPe`hVB!D7e3??YYh2-|gkN$K$y`I_9Ufoj+&8H`mh1MC-4Q z>F#_;6sES**Wd2x>g2KA>(g$>7joAEs;-p$s^MmW*9>}3V|TaySMxQ_mf(E`ja|y6 zl@G0(Eu&?N#I10I`I+mw$#A9TH!R0{A%uD1b*nPW&rXnjQp}$W_vjp$&Wi9}ShVgN zt8B~9mUhM(bH+7!yY0RJQCXTkq1Y+=K)=CE+VTzjbtcWO#IN z;#hUt(W%{gk5zw>e6V_S>Y}~J&UFl|hO_lt05|)sW#0Q?v6(*U$X_BB0ci@CFo zkUec=U(_VT)yriA#x*wxhW7 zpZK7Sw&QBhi2`eIJFW&fbt#x_gJ5BsWS<9@5+hyq*_hcjvuz`{L4o*LPS|#P)(1K0 zntCa`W`HrjO7|>||54n%b`;l^^OXc+2*I{iQyG+TS131o%mw`^;9}cjuEvkK%oan3 zFg@B)T(iXsnTyO8n=OU}qEKc&=hmv(Vu;UdvC|>*i_I_gI#9-ra1J{mw%&DnWQo3_ zW=9Up7WY&V2m!%taVmqdw#fWq=#TAD$S~5MGCE{mVw^u>V0#p1ix)B%nJqS3tTtF< zv&E1^8%H9{7DI047pF2PGma=Xv&GOK^NZCCOI${W>?m&Ie~+-^YIa=Bj;q0>_~Uvq z*XVxiQaG+=uNgG_XB@L_X4}lREn(YsVjac3(2nBTk%LNt@q}Q@`BVmFmSVP?w<8B` z0L8y$bcoA&v&E2~9shDlWVYCBvDbkzc7$`09si2$FjHk@Xtvmn9N3>fa?m9BL0G_C zWRJNZKYPq2YNS79ZLuB2h2+dHcIvYLTV!7?fCvlNB01X9g)hVl-U9T+f9(Q&^NZC2 z&&OtqAqzYH)zh;cayZ571#K+$qv-dE&FsQhG+PY$7O;h8iy@~j=%0KNLXSk)D{4JG zt0CvjfL_4U0Bd}@&!_u+daX~d^J&@*mWM2*{szQVz&QX0+7kW&=&zVSAbuW8K{%IR zB!cbLbe~U)ZNP1bk#GOp17Vmgc1LErU<+)I0{T^8F0#+)H2#c^eH9lv1Y0d*36~NF zw*ASp?F{}%;xm~ppmQ=Obb8Depu4Qspat4*en0fH(|U(FT*ig^opuzroS#`mpM-uT zea#%dQfy0Ld(^L#F^wt`BVXn-q$NhWtlz1AtJyXP5xOmMEnr(j-dz}5g0}#Dvu)_F zF35k$**1*%RrEu+K0W?l#k~lua67h-Ed2|Bt`gN5_hfm!1u>V~rvWhBWZBI;F2A{5 zw;53JX_?S%s7K;+%&;ZT6CnIY(Er{%6LRss3j)@pa;FVnEPxJz_v)od|z19OXv z5nM`)bSoFSkxMLFy#>ak*quH?zee?oP`8gjf=( zKAA1H$6T-pW{WY*xlU?uEgcIW0oe>}|gC?F2oqiDECW473A@znIl%*^QI#LQLmUj($T;@VenSn zfijQFPnhiv#S|~(k-II=A;JQFp*`k;oXjuIeavM?am^O@R1ydQ zVF7-j*<#4gY_a>qK$9aUwnvfwDA|tU+EHBlw+PtKN`fDR1wiJ%5*->0Oifc!4xz@L%xGi2YS#q`w{>iEn=P2%3b`;l+98?nc z9S959TD0Xni)D?8ONo)TqpkB_Bc_c$ zA;ww(ztjAF=x(?CezkRWw6&*a4dlET&daX~d^JzZ2ssilUl093>`O-UW ztE}nFwzYhYE_1WlHuiq+g2WEVtcmKfn=!~ZN_YX`= zP6Ri4r=sksG+R8Pl_$fJ!Q%1By`7?hENm4IAt2Z)K9zy3;%yc021Wb7Wpv1F@%*Y? zo;pD662msjsugL8krq!2X^ESx^6h`SAfzTQu-gCGLOxyaL`824tOP`#yFg#?7N9TV zrwjB2ukJD|(H&Jg(TcGF+iE+ikc0hi*KK+KZ^!k5?9>*pHOqRgQCqh}c2w=jy|ZoR zXF?9P=1*l%X1zwa$=q1L_KBW#!Ot>36Z)&RcZvF$W{b@h_f!%H0l{o>Dg(2{w*Tq| zMf<;HbjUuOZTqkG;cSexN`fDR1hJF0ey%GoyaGa-isJh`?tKjc@y&$cx`G#m0&|g_qH27K%KT#J5T2EpU%W6| zWPWimTV#GQoIhhn%{ge|Dl3a-}WhH#zxs zz-pi7>3^on{2PJ2U9j+{ECpT=$}2^YW#G|PP9UYutKpNRmj11 zRBcCf8SSXrlY3{|?8!ak(C%IX>e-qf@+;tH*_t16>VluY9M=41i_I4IR1ydQ!EA9V zgR*b&+L|BwQ(!K#HGktZzu98wkez6yB~I-SZE{&#WPUN^SHKpTUko{!Uu-8@p$1|z zV0&AAc}u_K^<fb*wF*y<3=$(qPr_yZkfL5L?6npHSuI(EE_Kg6Hg-U`S1b9da zWp^=bM-{Rw;MsR|WwFG+3uxbHg$~({DujTr09#}`s*qm+TVy+`kW&|SnZ(8~aa(LB zTA>@Z>tMSMw(GFGb{(*zYESN+ZL<@tkc0V|sSIq*k11bwB$vuJB$l|JX|~vGaZe?I z5D?53r!p{GY_`}9iuQlY=#YIc+n$BlvoMUcN`fDR1Wk&!WzF_V5h#I zL$?2F`>(eDy6pB}&9<3sgMVeV&1~E9vTeuhL@QVN=~>!!eq^m0pE~3(E5oBRdX9GG zVZEvhPY=%e5-V@jtIEwYBSVT}=*XBBxJ6Ift{fa!w1-9pr}cVhaQXo38s0FH^R?@6 z&6B-4&esl2PRx!@%uUYCWOCLG4bF}nnw%aT8XU`HHLkQ+IqQZ;hYnB9PLAjB-6X4V zlj7F4>bO<&9nfwcu56>@_?lQFSSy|C7RceXFMndSC{n@IqX!2kj$~A9&C4cUH!*qZ zMCNwiQFp@pm{(^!HjZ$u9~_%HJUB5oJ_5aMKQEHjs`^n^$sb`6E4@RLV{_x$fSl34 zcuEvC=OncZ!-KPf{(9wsBmQdj*x-Q?H7@-#vxBpvGqVt-^9p*0M-Pq8s>P|y9+?`^ zdbbRY&1qr{&-{;0sF_>ulLNCOx2ZWx?~#PZQJI;X*6TG>Bhy186KQgEVrXn`cm!Pv zg^t>@+Sgt?J9uDhWZ=N$u(stScV}ky$k;qH{V-=^17m2Fat;eQtWD}2otT6C4^AtM{zJ2RLs(nIml*KbR*Cu9RvO#WeEq=m2c6&YvTG(L)Z#|h zGJm+aMD>IjXK=;c7MX}lV&s<8c&r|4 zoCs`820>?Y8gmfkL`0*UwiB_)Y~UBLgDWoZW^%=adU3J8=#~Xsu}3MTwD&5>z}T(W zrNwsZMSaD9Y3=-;giFa&c3rY#cXivYy*n&{T|j!9Dim^Uizz z;lb&_A+%k*<@3%{H9GIS{nh7G_w2@q+C2 z!=nd}49NHjJ(ZKf41L=}s&unS z7e$d1rYlk>vW+uSgA)^27!4dA85~YW?FKH=22u&Cq;G7uIyAK!k#SrS#~It9d}qg**R^i9qw%;}cW`og9Nt{u z3~rj67@m}Eu>qF}{&f~nRnpC;$S?GXo*uRmb4X}4SHaputyBzaZl0T*nVVKKwT2|; z#s*#K)i8*?baFwzpE0ol)7s#Aoxfi1bF(cYOO z;|C`Bu%;QCp55ce=9+`!vjYd`xHI02Pd|>2BcD@)v+yHZ@p*#DGtwE|>+g+Ryat}% zM)h@Khw!BIcCfYn)bwV)7nwKx&&}#7`4a^>O8~sXI0^ zfag7j)UK_cnw)`xg-RwXXRcsr8Zma)z)(?8(==HB;;x_VjT!GhHMp+w8uexvBahdi zfxN<(mAuftopy9woZn;BZAYhe?>%;Y_2|?^dymoch2H0(y0Q_fwMQoe%Q5krSsOq` z<(mrrdW)~k`_~26m-8A-=UZoe_{Nrn+^?LN^h}0#dk4pE9X#SKAqmxpJS;K);Evh* zvf04{Jm$}O-a>(j6v$5C{ihNONo61Qc{$8AYp+hv_0!QRxWG9rt_+P}m7WUxIUe~f zjD1JQq1s20#?-a)F~sWurva#O=K$Ckx+c8GnM42Dk9oYWdFUj`>qE>u{@tJEaleQ4 z_yC`I6prSR-dO-H-x+TNunect-v+SWlYIPS#G3&$TfBdYPxD|f>rlXo_f%Z7%u@kR z2e97h0N(p8pFRUI>#=QGPidZsdo0U(N|R-IkGQJL=li_pAtwD70KNqX>HiMW#B&88r2j&sN&iX!=|2p}qyM|OPx>zcWa(ey^R7lr z`uhQY1_}QUK}yTR=#E7t*ZvG9TZ7nDzGp$j|ivt*?A#$H(va zvM)!hy82376HgUD{I3Eq{b~U5z5<~5Zo)OoyvE0ah*|akfMo{&Ne}X4nX|WS;b$ZjngO}wvl$6Y4SCovSMB1*agS}e2SDBb1Yi~5lhBpN5mQ$_1t319d!J8#+Q*+kOg@y( zy||{_nWoPDCF0Ot>_eLP^6Zu7Js0`ps|HY>KZ|SD`#gYop95jVtIF9OI*6~OeD z08DEie%Ytrf|&VV@oDnP^jCeFde8KOKK*K+{+ds#4m^Og^6+(E=9@l#2r>Em20+Vv z%jbRD$KOHBG7keNvnoK#s;)L0@83gt^7(xL@q8CRJU;*^o*&_wc|Qg)?@@r}DGeQ; zKSdtPJ_b;I`&a(n?;~dYKL9kU|3CS%e~4J?|Ihy39|iUP7}wXS(Rys(>L88F z?HN30X3|HQW(eDlq_huhkrgWOl7`a3WhB=|_fbyjBNqG`1Fx)Uh<6R3QT;~uQAO%2 zzHA)!V_%H__DuVQKa@YFa#)ME1>iFEuZ1uoMb!=qf(ClH9#6iaD(OoDqIb9tYpPD_g!%=^u za}XWSC#OfMvp9@eot#h(4jegF)$;*F%b-k$ zoz6zG@j)Z^XN09nA@x~)U0gn4d9BZU8s9K|Qjo@FRylWM=)FmsAM%NM*}?4l??$dWW-X`kK?%148e z_?`?1^0V!Y@U#5Marrw!{*V22nREFu!4?%?bzV{KggQX^Ajaykv}y zXuw#VZag*4*M=!x*%U*O!n$#Kj4!Jjf-mHclX}2kQ{DLO2D;%+W6vuH+kHli_wAVu ziQ0vt+TPqaeda(Vvo=nfmfE;&arq4y)sIYAyg9ALDKulj zCUsu6ZdQY4)L>1A4L>(vjD2=qkjCZq45Mde((h!NfqVe3_yNT8Oh6!@cV+5DehZ35 z&Li;1lMCWGKgRR!5D)XW$NBwXen3B~vw|O0m2ZiI@=bN`DOp?U-g=2NFCq{SdXE=a zqkLh64WnZiFqG9udCU`bh>wA6dBrM*AQ6 zE%oWb0Dr)D+XMWf03R;j7xK&YTpZ`WKg>r~)PAHR3&^v$?tlz)V%;O|O8`L|N*R{` zpZ2ZBk&ctjr7@jsA4)y#1D5A*rt-z~vx77)v$Fm`MkXI*n!y`WiIL38D&kkmYpnbz zAGlwqo80LM@|(6RDAy64R6aFUekrfZoAV_)9+ux1m%p3xQ+|oB7Nl`mr=!n}^Rqe{ z^)HH+($VL|xZBlH)q$w(K%J`tp=_QX&{vt@R#pcKP3S@WNQS}vj>#^-*{;m0)C2ba z3j!J7vTja%VVqxdP89s88jaI{@21Yf>Df7vj=y`mHkueCA^|a-7^8f2{D;(dgxh67 zJzIM9jRaj|f zP=6^XtQ<6=3|BE3FF`ti`dG5=+8{wK2eH^lj$%;w)1 z=Vv?YQ(<`&y_ac*yt$9}!_A%k&>_fH(sXD;UyhqW?>CiTE89ll{9cT&PI#|~^Xr87 z$~eDHc(01{J1RW)@emL|2!*X_$W2Bk+xcohQMt9Y3&eO+jImB~195(xI#^vuLKE4Ns(q)9xu$hBt1{JC^K)aBQ6Pgtj}@AfuTi!P)G@_RT{#2@ z>U}!fr-$SGrmI8Z8;#3v2=O6Hww#qd(z%a{alekw*WzBl=Vv@#*`Y(0?$oKzD>3Lu ze;{A`Mdh!$s4IHyC*9H0mB0Fw8rSjlx|px~GwoHn+RsX_4$oMOCp&hueNvBd9*@g^ zHbXZmkD?L(NY~Myi1B6Ve=fvN`jbKVpkK1q@dIH!RQVv&4AeudM|@L38ke6B>oNc4 zIR6VF9%R+EXF4uF1XJR~Axjc~Nb2cvj#XNc;{<*k(7Jsx;M1F1w z$}@dykj7copo}04mIuhiQ?(2gzE?d$4a!5C9|Iq*s@!lS!3*h}q zBfQ6AJkcCNI&X;cJGPSsv@-S(t4@lIBh5DgROYz+YA9o*BU=a=ZDu~}C4ivbm6>|c z%Q`5kbRT3n1hsWv^J#rf`eMcZCKL+rH(K+3-PafVL>&4nVV}M^z(@Y?2-3K0r7PbE z>4bRS662}s)3?U?i_)iWi)j|_)3?X(5Q)yqmBgVVnzI+iyfda*xG&!u*SjLqX7K^o=DXr@-(tB?zuy<_&)4+b#r!lfy zwKvzFL%nER1o*Q05%B~4mGK{xZ`9tVzD>|B-EEe3>V1vF@$y;R4CsD0Be(DQw0wYy z{r0)Ie0Cg1o0a?+Ecb9idY_N$3tr7fme50-%Xg#uTA%!V0if++`hg&g%U1pReYTf@ zKBMBrrL0e~_lf_D0Hue^A9#6bd0p4YoQQmlBmBhkr5Mltupa{a>%#k}qWD!_qDQ!2 zhyTkl{vU>TNdGHweknSrs`TsVel^A$wF_Ah|K#JrxcrYoKC|VKE;?@rU&Q~l7=M)!~xz%nXh~Y_nXdjIpyyN@c?BcyfeaQoHMi2m%7iwY@e9K_uqxQzA6$`JKcT7 z@+d!~j?Z$p2+wYrwy z*Ni!vIG6h_4B_5DqqNG94GcqyTDyZp1Zh)oHGbd{u?oeHMUHJqJL#zYTaAfa99?7=TmWC@0Uv zfpj|l(fjq|e|T!_2p^eI0t9`@dd=L#q3OxFDcn-NNV}B{Wqzl$Oz~_?fD|E+ckZ<- zRrgz}ZwjVEIncr%n)W6;N2u{LA%a_$K~N@eO&W^4JW#$XU)IdUqECj%S7ENmeGYN-lu!kpMkgxKP=xVezJ5a zLhvY{CUP6nDq5YZ^y30%j<(z)SuUDo^W(AO>R z&qXC|Egf8S_}SXS00ug!uL6+C>j4bRS4lk6rNyDe{b(t?EDcg@OEOhnv~C(7th#i1jZ50IwYRQh7GQa~8_d zUgqJs*x`|*VTz}T-AdcRdY#gT?Bo`H$UR{4qUP`|*wj4N;VEirQaQ0+r}`(WR!hm$ zJkQDRH__Cj(=v6rQ@WsIqKJv>Bwdcx%K?m^4^Ten0yJ|2HY1eK)uCY?npa8_d{$CV)?8K+jRw?j2u|L zQ*uzc)P+!gLOr4TM?S9vfbWlzf2H4>Adw$R=>hP{=WIylcL0p90w{kA(eD=l5AYY( z@83mvZC@opA`Ye6rTjP1Z#jL>_L9#mUGTkB^jq4Y?OjNJUG3UjxWBH+ksEGl=yZR{ z+qCR2^0|cjD{aSqw4)RK_F~{EGtOR;BR|~I(CL2Ls`Ci>T*Cd9w&SH}N7g4j_2B5( znEa3=9- zLJ&%gU!~cX1Q_x!OW{Rl%fSc5-|cN}RURs5sGzDmMMl@lQMb|PYVPic|qrsHvu>89gik?E#(V3Fyj&oma9Zn|gGNxIPg`*mEs4&$PL zey4iI@{2gG(*EuwU9|tR+Wzrk?N99r%P(U4)Bf)yUCsq#0LGI5?f)`f_Y~?uj`HO| zt>24#oVRq7=^R`$pq$JTq<6DRe}VE>Irb(<aI(u0lH;(8|r|wo5+dc zIU|GTETrjKFs3w#hf?NAf8r)C#?&~*^l%tcgBi1@7?VH7>i{7y=mly05yap{)?;kj z>j7D5G<;jP@4)E9@PPX`j5dTS5elSCLpGys*bt_}hA_>ButB83G#kP+_g$IhK5f`g zzP`nV9R-99y&dVo4c&+~4h#*>jvSht9vvDSLtSleI|^{j@v`6}DsOOjN*_^SJspOX z1PKJlMxoS@%gXS098uu_p+4j+BhzV%GVfHI6;HSJ%2l_@Oh<2Y{rA-;5NrJ=a!FsG zWIb(9B|!qAU0qN-eTkrH_ESp7z>n~&?V^off9o`RHm<`lPs7PEp8!zzO3FleTf>`; zLs`By7nFCpT%a9NUMh)Wq+NNV-h&0{r|-3NnEu!D=x=k)5W)ojxA(Cg)Mw^UVOxo8g!`8EN+8n*q?f)M2;- z>FgZP&|#2yba-^=@Z{{|_~hIS>T3JjnMdE^cvO4xBcdE^b=R}%E-{$(T^gPOX+MY^+1VX#Ipm@4HkM@Gc(B_2WUFXoZyLNn&c3%1F zO_0bBrEDMMQ+ocS{ZT$DiDRN&Iip_b`Lo0HbLY<-KQ`Td>o9%6t2S8u#k~3Z9XWD$ z(wE<|{T|KV&qy4mm57>wE4ApqrP`*l+zK|sv2_;G98-)bXO1lauQ<4?o zi8_5#=ACM@;yIC~?>n6?l%Bp>Puo*TkU(g6T2VZGiJ)orQ_8e}pJ*9eWcq%uYsVFf zF@4iig(i>YizY5~D`@(-jJOMc_I!(csmVMQ*R0R!kFq}uU|_yJ_2rVEIEb6=XG~K` z8r&1z0^m}LruKRO198!OlJ5IlTAt?M{wmVv{r9{34{Q1ZNGo6MEKNS>@GaQ3-RoVu$?mIbxfKW$8w)_SVE)ZFfB!QG15a) zo$O!8Q}Am0PD`8+n+! z>B2*L9aq1lzO0#!XVTUFsU%1saC~@ZOQvPU^CumxXgoKuLoz-oFV^c6--@T(FVa{RI#>W80&Ys#Hzwu8Pn^>7P- zzBu{RYg`I_wGW?jY4OXmc0vF44gAWBb8OG&U3qDrwrf*@n>m4W8$qUcss2=cl>TC^ z8@ja>g!Y{I1O!6)&iVKO#M%BhWomkKVwT4(2ZkmmhDT>dCnsin`7a<={b-_>DIJzq z`Bf4m5Wt5*+5Y%}^8ZEPD8mQKcZ!b!bkjrpoumu7{ZQNg<)Hl>V;rX(kCg3I00xd# zrrA&I^RKwH^bPJuzRQ{fnFuUT$b?e;L|R`0(5C&`A-a})lOLacX(lbaAU}Qj%=R&` zyz<%vpR_5!-wNN4RE`era{AnEpCI<=@WZ zk8e19KW2X_o^x=WH~((Nea>5)hdCyg=KRGpb&F|^C8oKyW4hm`o2~y@euFPhf0}99 zRMu~Fy6v0DgI-_u1Y+g8h&^S!PU#=$i(VI?pXx)0=@(r$rsJT)^o#DNrS`nT^ou?! zNMFwCFnz&Wp#LwYo^rf)n7-gGK!0DC=nLKg^lM$BFL-r4pOZkqCuS%$|EoOp@rkY< zG!FOhH>16@d(QxH{@w!Mz3lpe_h_S8jsdnyY&3Q9A(xhyznK1(ON(toxqI1nh~`ZdK#ryO1V6G4MBK-|BL1%dkbbqMzk_tPJ=7}(wukx?)@S)F ze=O&r6n|N|+kl6GxY%a$`v@RQ54SXwqDOq+1^|Dm(QW2`7tq8%&idOwp&Y?$ z>TeStgZH;3zX?9+7q->=^R4hbrv3H<)KU4-M+^P5vydiE`cLe?%>e4vvnvX7xw7)0iMRn#}Y??JZ6DBHUfI@jes6}BLH2}ZV0Mj zWn<2O?EptW5n%r*Y{hjm;3!g{#ma;8a9`nkTo-|zC`ZtG8t=xvB5)zfDO`l>Jh%k+ z6)wef5x5-X2wG3$8tyfM=OHf-UV!@wFT`~b;4Tb7>uLNV+-n3^BQFp3@Ay3H%Uw3O~km2tPqu;W1n{gWpGf7XCHvDf}U>o53F; zKM#I}`(@!zQ6~@n4ek^ET>yHI@m~~#|A2A|KgV?u_>U;3@K?BQ2LB293V(y^R`7Qy zL-;QN=sm{&*aCiqe1%`&+Cv#Xnq_%1V%5p0zYeegP_6C7FG3n$_{R)CtL;4~p|<;> zJq)$or+*CLp4$105MS)`wY-!#@%m07&-UiOn zqpBP1>Aus`J>Mh~V#H)_5)vjKGnww0NkSmZMN|lefh3q932AP3-$|w_E*sc=-F;timv;mHRDLG=|DUS!bUn}g zs;B!tGjltqe!sd^r#?66~%L{uZNcV3SZ7GKAqyZ zLDN0u@a^&OzI~tvb^9_b=p%NWcLxHOVH(bKjB92!ox0gH8csKZpZ&8A{Ua+@{SVD` z`>~uEM&P;|)pK);W#!=E>crCA0@6MQ>pGX}5llthdp$f~7Ek4P-MP~lc>HeZg-X>E zZ}M43Jar#9AQ%ENbk#-+dW8_vDsFCG5-2c5h4j7z^LPG9AihfjL= zt~27P+<&2~$2~s(v2VKY@v?Il{@SOjh>IUbhkNS+SJb_yl7?%~IQXqTeD-k%Qryh6V?|8<$d}p(nnw@z(iIRfc{1;EspB_Sz?RRED1v zPi4y^mpy&QKRi;|cHgdVf8nwF8r-4BB%+daH_Q|91C=4EUSDOH#XRwq%61^T?CCoz z7ZU4bPgl0Hw1>V{+2Z*vDc{#;i_fR^)ch~<`L{~7u1WB0W-WL9Q)RO+XS=IMLWh!% z-{9-j@9RJ8@on<$-Q?T9S>t`U(kV&j!?#N_URTljZe?pX-defHmvhl)cW=GBbV=o+ zs%!5$*WQEw;@Wrc-#mQ>d_6Y%c5RaGI91uI?Pc@6{l$aN`F5<6?%8?ppAQ^-_#Z!T zv@-1R4Ep?9|3O!ugbsU;IXaE3cl|s1G1tHQe7|Y<{+nGt-Qel5-?!(+zjxzz^mfNb zqaGfS;KP*>-=CvC{m8$vqfb>vzU=ycgt8qjj&~xN`6&96QG|)!_;-5jlUYNZZ-wO zY1DO)gS8%-H=9P&#<-nugz*`F!(`a+>l>zHSZKqz(BCNy#>&Y6u44sIk~LWGP48YY_#)*Qf79foekQ)P|C#4Q)<#Y8?=3)l!+a>vrgL= zN}1UCJnOVw<7LW`h1Yji<@cMXa$IbFcWi#H=n(EiZwmk7#qHW!ke&q?CC)EOgny&p zd9~P}jd*oHAAWWPT8MiFI|ns_7Xf`P3z7E`dxaVs^Z__mVFMQzr)Kqh+o)mGXvqxA zFNuXZ*ScAMKECdddh{}cMe$^-Flr3W)F!8@O8$ZQ(F1xRWBw-f_F|g#)79~s>T2sJ zrmKsKzF~vYwd1vEg;G)JOf4~_lZCj?eN1fYV$-cZG&VP`#2P##FQ0ls4j"x!M zsFa;gMbBrV4VBR<;gvPd44BE%H{6;`WLNotV^N&r3Zus08^SrR{|>$K*?-4Am0UfO zV(Z=2g{kWJbgg`QFu^T{zNY0&*F4Q~XmfncL&H)!VR)gWP0y&yRO#IQmFFBfG`FXW z`FT$=C70iT`FMFPw&hUy(A@0q^m29hs%)yOnxrz^jg&K*7){Rg*b&9TUwf2`{XC4~ z2c>!ivJ5}JH(Pg*pYb}Qas1*+{bl%Fx-YpzK^(&y)A5sDXEbgbK=qg5clf^Q5(ROa z1AiHQm+o)jb4GFSa}D*E;dkl&!X*mgV%x#b3>xwMO#?n$WN4D^>4tQ%_}C|n7jdsR^I5{pI2mvgI$LQbq9Yd%6gBe?1+R zDOM}UE9+4S-7WQ~q`a6OmC)Tqk4nlb>6wJnb4R8os@b;lhI!kB3BgryU%u9j%c>Cs zcQ@Bv$`xPYi77{Ju&2kOj!RUuaf~w18{z4L-&8P_)^Mb0XY@Ef>EZR066Vz_@Btz( zA<08^-vL+ik_W%YMwsyS<#4GVTnx+k@KRXD(dE3n6PBNT5~hAYn4feKrXE0;U$_(I zTMdLcPZOqIM40#qlV1pPjFn-phNWS-6wKcu07Lw&C(Jd^wYbWLxYFJ6)-vw@)ovfWeTJ5(E=%!5dM&^mhT}3*LzGg}(|YU+_khFZ^6U`GPm1d>KCllrMO799>?=fH?Oi&)79t z>}4|KoylVGu9yG0=Kzz%Zf=i|MJ9{EXC{jq^eD>WYoXV*)r+aGo(;XYjB-Lfn7VNj zJ@`86p@Cj1`X%5_dTd@jxs~24BIce#=RVzUwR3*Ea|Kyucdpv&p?2r07(GyQi3nM^rq3RGTo&6o zKgNcw`Q1xFt?t!gjyW&xH%7=BTk{tq>+PH$blnMScl+&be~WJ#OwTMv_L!aty7su9 zY2R6)520t;{wwHU`>zQNZ2uL*f@k+J-}jv_>yRFo#kS^mve?e~IqsU@&7+LAH9zPR zvFEU+^?sFgcDLWY=Wlb@=Ujc)Wcz)PQAOSHiI9D=o++SwTl1q|RrcCBzn$|#AG33Q zjEOdL(3;l6Ocr-Mcd$EG&DU~vx8Lse_tgGcgsd~Yzd*fT^-f#!+nT?PzGZ9vV2xI) z1Atk@*_P<95wcJAtqWLl3*LzGZOxB7`5`T4)3kOh5od3MV+KF_lWulKOM z;nz{$vNb<=MfHMG9RQ52`4bxCeYeW=Oz@BLldbtp7TcP?;~Zpbe#ndh_CHM)_r5H) zH9z{$*8H~Sw>7`5`EAYb_B@`0OoYk)PpQ2d1){Y1ror?~(8u&l4xQySdZ|t*+3(=q zPu@Kb`<@^4v;9|Lqdv-JTl3qRAA5l9<|6yf3iK&pE?Nt+*w*~u4O{cun%~y^w&u4r zzpeSF=4Kafo1Ltkz`Wq~Yx{;2w21h&!1PShGv^m-_B}t?K=%Kd=#?@?5HBv`<+~BU z;sTa61z>RjiwuHe`>!AZ_Bu=!gAOK(JMQ_&_^~yAQ(0_levF|evbmM4y^jAS88POD zn6BGA7g4Uv9o;S$vR3d$lwasrizr{_gaX=ca}D@e@0Z#ee)fi6oAd5-CHrjb7cl2Q z_S?JtadUp5bDzpyyW4Mf`|X^+19=@j6Aw4dOZOxCdVQYRn=eKiy zJLk7^emm#4bN+^V4z}jEH9shjGI_pF;D18fyZs;^^h`VF2OY3yp*9a6**U-Mzn&Lo zkGAIT&O29S$bqY2X($u6!hVYY4ByT2-5;3O(zH*k81>KJ-rk_Z;lqe$bWQl-e799nV-qCU=_$ zZR~fXyS>|AjO;T#6Lig(JZm*u^ZT_L^iEszgOO~_pU@!BI3nF_{}ucbp$inc4zV@A zt@(HO36ZkQ|5x+5(tAZe>9)R&cAXb`PsCWaH9vT;fd22rHUIVazJ_zEjK%MOF5EXH z4*z0=f&LD<9epaV$3hL<_8gAIM;fccg-vM zU4$NJcl$x(0`x$;+Yh>$Ebh*lpZYfSaGs^{jK2&Up8IbH+~nL}-jb#c@9zPKeh*k= z1A@f`-0583_Fq9Plf?-Q^3FxJ{|f$zn2T-ywRWP_J6HQ{kHYlgQXK;c#$<6q1CzxV z7LW~n)PdIFmR*PM&}@%_11N3s@DT4Mm@EeUY>&b*k;!6{#hwT9$Pv!rCX3T@m{1-X znk=?EVguY4D%J4=W3o7*L7s6$y4fBD_{a7rWEkmB9v-4BK45zkrWcp$j(toPn=JM` zkVlS~UaZnL?dGAO$zs!sO)tjyDb?`RM^kUG@^kQKn{V`b#O4vOLcPG5bHy!qE z0r;bUJ7p$|L06N-Du%_)D~oTmJqp{SDAgSgtwJxf`^6w(ge;P~lLgELcE1?(@A3P^ zCX3OBc8|hjF)6T$xybZl&@W;xvirrY?-!da1`nAmrX*UGEHb?q^ox*1rWb=w1*{81 z#`m~he3R`_m@F>UF+gBep%Nefc@3uz)x<>Gy?NPMeqcFV~JY;(mAOei(#R(1aoPm>WCX2y8CW~bl z=}#UW;{D>AZI8laajEXu$7Hd|V$TD4!rQf>O&r$>FSmUg+qWsz!PGFTkWY5E z1oVs0mF=D%=v07yuomw5nJflx*m)+10AsQ^p+PP^4|KDA8}LuWTx54kTHh@(SqvUB zSxiZs$RWz)yt2sjV$d%_7MWfQI+D%o0oBrb+TqdcZmzwWZUdy z?S!X;$u>79M#$DR{r{~!CfjTcjqwXvCTkmb#Rc3+4{Rm->{~eyvCVg@YkKTQ$Ua*` zgFgz;t7UzrviI^j3OV;CubyeL7=324*fB2jNj+c6!$-_xYfRA2WU;*=;YO1D<{3kF z=W2P4Z+h{v9JaHi{AX)+&L1}yiT-MOv7Ie}UF>Yh$=p11Hf6J&Eyc;2HN6L;djNK} z)YrEG{IC<2-$L;Geb~brJ-o@oJeM!S+PQg2XtcfgowJxVrO2QH=5dp4;LnIPy~#Gv zsUVYQKDITqt)cCW0}RAc9X~Lu*w3{!H0T#0`)v)~TyHU1Y_iy7F=R-ojvpA4#R(1a z=yd1J9*eH=?VP`_Z$0>#Yy3f2uJQA%`I#QHl>EFWUxp3$0JZ~ea(7Jo=v2U-)LOW6W#27>NSQqI zxt;UdIlrCrWB8Qn_<>o)y1-;H=x2Jdu#x`cmBn_p1j;qhlUu!=VsGMsUTxk^DRd1Q zG1g_Dw19JD+kZvB_t^fc$u^U1(68)lsl(Zt$+q5;ZFaWgWSi}0f)1-#L)zE}{UY>A zyPpX<6`)tIh5MN%i%k~ymFge@jLG7J26^_PNH^Qh1ph?LMTPFM=o;U?Te9z#FedG- zXpG4=`<-k0E_sA3GQAl5VR~`Hon^b*-}(-goh{jal7#=sVtX)b6QXG?ar1fHtN>Xkcq7U$bRA-{*sTHie@XU#OD2mk9@^~*m@GC~Y}&~i<+(oZwAg;8$T2%x^8BzFZjzlh1?&Oz;{L0h zErA#8+}!?e$^LK2{%?tQ;(2F=F8{Z{?#hD*F#bJIyDJY`w0RHI?q`BN1?W|FR~~e= zyYlwk64=0GF=!C6#x+?CI+-lyh*_4Mr8=SHT#x(edG-RC-p=_!KhukajZ7AU3?_>^ zo^#usEAUAHbJ1Fm#kT(n-mv{w+kdtF*EP5QYO>8_8`exF+f25tIoW3SGo5U+@0LIZ zyDOj2An$&f-IWLbMC_s1U3t4JFJ~HH7jc`cnN1d(EMCoAWU|;~F({BSdFFH8l{dW@ zm#Rx+dkyL{N*EXPt$+*q`i7r}!I%r>6?9}WL53a8*EX*x0>jq z?kl&FUkUZ~*HLK*q{YnFZ|i-|(nNJ(vWb6iX?%KY^01E?0Hj4tR+p-K4ll3~qI9Lm zqZdFoG5g}NnVIUsNtdjjIx5#@bT`3ng)LVO;1?!wZ~PL?UsVnq7E>90Y9CEy^pcOj ze6(^s9k@69cug;Po%clEnLoW6?U zxz^W1%YB6}=N6w%@!X*4o^ts1_;}ww(1UBhGA#G1X|azXF5jdeOqXFAu3-$%T1}^J zyLiSaE~IBSu2U`_@SVMGzj|&|&&?S|(jFf?T%A|~Lpnv=b?zh}n2NghdU(Dpp33pM zbEh-#_}$VAm8vJ+OSyF*Qr_ew8!`G8He|jhwu7~OMmA#oO{P#I{fz!I(P9I zmmY(JrgH2V=aO|{DtDc6?)?|KdfemlAN!^YA1^z1;jewVin#c3bhx)Ja7EpFDrva( zjDz3m!)G6N@EgVHtK4(O!S`p}!*v&)b*CP8;qQ3HxzlHy`=+{cUoTEyn@+BTk>?d*To~!(P5jAZ(l{-t?UjA_Ms=fvhmjWPgRC} z{NRp>NqZ-3#j`x@M#$0VYXbvMit@dK41sa{`Y zn8iHtmCAM?yX@&ZD;E;$WlvYOv$Ti4R@vhDEh*pEXN%9L_0;??^7*$)wXR9{7|E z3T^`Q(`cBwF0}DiLMN+^(4E6EDb&oHg5rU@&iVVYO-F>jbp z!^5!kNHgftr5ZJ;Z5dI|sCpWknQ!uEIf=f!$zvUunODtqVB(}IlcmY2#d)8i|ET&( zlM9Is-2b3z!=(onYZIFG_@er%Gu~G^Qmd*yOs#g@^-Y5&{7k0LRM&~ucx52~n#z_v zY3o(m{_OzJDRq7V^xdasYLipd+0*4+r{+fwoGyR8{=xF8`I`=$zQ$ExJ(R6i!*a9V zaz;|fEi8vmIkL7P<$0a3(+FAVun0z0f7}QW=2P~i3ss3XJFf?0vX(<+(C;`Vm0J^( zEnKl&4$FTLzZjNs$X?TPvY0#TFxlHi_L?4u!uiYodA_f22RQ_W?6bz{N)H4pUTRtWW%Hgl25 zV$jEA@#5mt-0b3Q%l{~DdhznDdXvQ%BVH$2iC$u|81yq)+;J|lmjIgU_V)Fu$>MIU z5lt4GERLCrOct9gmahUaT*SqmMD}Y_(~C_nUd_5d_{sEQ(~B{T)a2RoHoe&NV$+K; za!Pglz^r1A#$++*7cm!^UffzQwpUreLrwH#`NA1d*?SV#@xDm}&kZqMx6ddd%C(mZ z3ZOe=wC%xwu6pm`(mH^%Z}RGyCfm?QCfnRi%Qkm#?8PbYNyOYDdrIA&(;!;~Z$$Z` z?-o$L;O!;ZhA}-r{esuIhy3mGL3f+mLj$nP;ho4hKo$zt>wrbj#G0v%SdwP>;!^fOs($6Ub_V6xcBR*?Boa5}u0az$vF0v~Jt*;!IEH+u( zSE_>uFeZx=8kj7GilWC_`fB6(er((0`^6@UA%jdW7Ex@nczHfDS!}Y{4T_cj=HVfJ z7Gc-bKx@ciS!2R0E?~QgyZpolWwc#a15ZS(!R@*l=v0s~*#^QwHpxB@yy61Rdp2gW z&175c1Q>|VazeJ-Ss&=2YwBM3%m8D4K=&-p{Z-rpb`{r_^QAh*5R7fDCN#*Su8?ka z%mx05P_gZptMxIL$zt#jrboMqYqEGXbCJnnlf|Gw%H)~PxwUGt800fq?0CrZV$+K~ z59E;}oWstGt#{oX>CsQr?8<@3;=WQHM1V0_oX{YzEHb?q{9}6*GK};m4-eT(jLTOH zY>&cZ@oMHGlf@>BRR*hTvKW+D!IcP;#h{z%#R(1aj3d&`WHI>1^kNmm;^yHYyNcWT z-y`h0nq613>uL}w{<@ybHM$?$3)j``GlQ1@jAOFRWShyh9+qwA*Hzpb?JBNaIVjaJ zo?vV_pU@!BQp}d~cIChgp!9DZ9^!J|WHIPx*S{PSnJhM0?0F!M9N}DK*T2$om{1-X znk=>}2lnTW95i+Oz^q~}vSTjL&yKl-jr1q4EViq-pq%N&j(t`ki|o|`kT60P$<>wu zUWgaG5#@{iT0r@x7pnwbc1;$87IyusuWvKxu*35OWi0lisP~D?EMP2}ECzieWTDAo z(5V3alP4kcN`!r)*4MWlblwR&2zx2)1`iK;c-X@mJ-o@olp9PBT1x({aLce)!_rWe z@DD)0MF58Qc`XIz8oo#b*{kr7heb9ZSX{*0KlgwbCX3yb*#cyN?NNZgBIY7{MyK^N zI`%3qcnGpu#uB{Z2D1GE%61xmCGk4K5j-bzLbu0!M7e8v4I0sY)BC}n-R3*Y;W92% z@3gD9`Si>(`XtmVscSaTD@C>hvPbnw8PmujF5+cA11v7!yn3hVttQ(*MDVuIHA1!s zy$cvyf;XaklWpj)0_fj!vJGQ?fO-hmr|14v+?!ApZpRL>O5cH{szi21m@Ka^hs)*m z#jqG|vg~FYm*3p3+X-9pur24^_Cka>5PEleI7F0dVhFt2ZMv(96+wU7S}lhDG7YPW z+oM~nCX2xvm|J9wz$-4`PAYUOl~}fVBgUl3Vh~%$PN@z6hI75Qd5&wDN4Cx*=q{?8 z$zmaQH|c*~EQyq#OcvWQ7i5CTVhnSxlUiJPSkr&V6)_i>UJTwSU@lw>da+%_1#g&M z3?jg+LNArQj|f?0vKVwOKo*INkD$NkuLYEEda;b4)K8wZoxO^?e8s@_C`=ZwW-gMw zj|f?4dT}vxk?F;ttDW7sxzJw^vpous!}cgz?$MYmHd#EsP+MG_nwwp`ZTUq&dllDS z#g*$k>mWV($;$TTSGK7yo)>G-2))zpi4-I2dhWWKy^3qE;_|AZ$+nKN-S(HkCwlJR z3!fR_Ol5%gUeAxKxHqFJb`{sIe}N(Gm}?cse73a;{)tfWWec=`W45)hwQ8~$JY-i6 zD2YuLn=DRvAkT66d9&T4DtV7y#Wh(B8Dz3pMDc2l+--Rd5=Q8ScFYAjnO@xVn9Hu> znk?=s)jG3XaD z7nv+JS!}Q3I$0z7YXNIS(~IL|k?m1{P6hDaS~$D2S8>4`*e@2n23~Oiw|XYWUd07% z&ea+;LhrJ<2K`fjtdnt}XJfr^UCplI+ErY;ip#aWUB&J2nMu#dHs~h<=g(E#E9@$+ zT{$S#p?AQnVr$Ws^PpdZifhYx(5V0wcP%XEO%{VU?D`jo0AsQ^p+VlOsG<^@EVe5L zZY0TX9v6XIGeHCx(=!tq9Aun1XX`>(~&e=Y34 znqCavFufQ=fHA!|p@Hee7#4bDA8{q)ymEiVN7Twl2R$ zOc{M%jI{{8)AWAuZc%!_$~wE++Sj)MblwR&1j{ojUY{ep(ZicO%(JU9teq{{*;132 z-YHvUO=q&L<2ky_%_iIAN!J0@lZX7(<#n^_Ii#L>?^%CnY;Jtf1A~XgW~LSu8a^~O zJ2x8y49=&b=aXpBi25&tB!k4`$-Uj80xfJ64SGJ?*_%nfAjE=$>QZz zyPP_J?BYT;%c>QyxPV2|0xWKuRlfai7l_p616KP#ThONfO;q?cVkIE_TtNAPH==wQ zKLwO8cy*VdM|V{1Mk~e!WUK9{f)4h-T_>9Tza7^LvQrx&Yu5B!qq43?c2w=;-pMx8 zGeHMi^CvXOvtA?JWNwU*eZpr2=vk&`f`3)^_Nbm|ve;yCU#Sivz?dvfXkfC~_Fvtg zSov=r9!V3OtwM4GTGMQu~Iu*!Z_(A*#>>ZZnXCC`vHD0!0!pr zdjfBTTZRq4AK;VC--4wXgndqYeR69lxYaboJHmivG{7q^V0$9~#DE4U^e8~H5WEqZ z-I_kxj%dG~Zh;RA;J>wSi^{$(aI)KO8aP?4yNY>s<`WqoA&X2F7bA=8rUB@xns|@i zG_V`3P8QpZR?xw2wAzi<7T+=V;*P4_qH?m$^i0rU6(`rW<_G;E^lV%6gHE>QUtFA; zn_awZ`HdmFMP;|B>=qSdL#d7*m{rV0c8d!1i8_8`ipZqt$M-ww>F0?raHb#{qkz z)o!#d-~K4oA?jgPy0aItqa~~D0#;GBibuai(BD?^pi=?-XE$0wSISbp$;qz+)_a(@ z{|V>$Hv;>*VD+ag5wgH!G5E3oSzxDIplbyG+38m6(=EHv3Le4=#dcId2isA#9o03o zqiQGjPPW;}J?OB~y$0m7H9zPVp=a5eA9N}}&tD5`ev`!}i~CA-5CO(yaYBQ^_t&gF?h&sv{Di$a)>fHuPidX81##fMWz>nPNo;zjaIOM$PCEdPA_li zOI{c7<_Ha6_JWMMj&Q`78)CX{^ISx^@|J41%SF2dZ$$Zp>OB$V+gV=$e24z;xm#cO zUu?V43SO|YCA-mTH(J}CE%uyj!2S$}A3ZhX-LgNMdu zrWO?%J~TEvHyZ>D&Zna1lW5U^`Y)6c`|O{t?Tr9?BLHKeRL2htG$gfocQI^76|{@c z>zO8tO&0f+>L3D)$>M|tCW}oL zyFsz?-#k2I?`7Lrn4N`Ttd;8cfmy{|WM^TZU&Q{iorSgjy1;IIfro7W)%IU)|8>pn zznW|_*#`Z}WShyhwI$om*^O4N^pm@^oBYTcn3+G~y`{;iMZHJce^h;?$%X2YPtpIN z`brNh)+Q9i#K~z*a9nTO_E%>V?U7n_LH!feg>lF=d|@Q_Yd68qo4q>DH%`pWE=|oI zn>)6ciPSp8b@8J`3Or@WpH9{`q+#%pvmYzdrXvS&K8vnlhviF z_xF#V^uG1e)$y7Nm*K^w>eAHW5=iN^g2BnDBU4K%aY{=k=WCkpcy;=i0vmYee`;36 z+-47sE!9q_I7`A|SM1Bld2Eq^2xi%W$e%WyQNmgzn%< zcUwxZWPsZ7MC7cWZVd#IDTAQ9F|BKmib)lkidiv`CYcTV2syZJzZaA1ZdA|B-cytW zT(?h4O3FTbhhfbGeA^BcuDu zyAa8)8o7C|hVR(7=cc_tzi02w618v7%YoZhZr`4L$TYg=fUDfTJvScExQj<_+H(`? zHFD#gn_upc?s+-TYMp(x6a=3ABgpJ|LW2(=_@?DdAjLkk-^C6ha^%Kro^113c_8)( z*~UEysWyzHV@bz7%ZU|Ct7{uPuA$@Ag(+%m0X!BcltT-14~FnC(vOA8X=)1CNHsDQ zJt!f2osL!FFu|3qzWzFXFlzo&M#EDbe~=p96Tk&CO!4K z3#Ch1H6vYc?X|BtT3x74fG)Dwx%OIL?Jd_{dzY?&lE97EUVEr~YkA)&Lee$a@W$h{ z1*|T7?v;U=A*?7J`?9CYZ7f;5X_`7BV9KytVK*H7CVpW$xj!oDHhfakxnYy+X$@=t z`n9eT6Q!e5SgASx`s(!55&e36+Z1_kexa5gs;QCuqM5nLslzA7+<*==sV!lIeukb3 z)M8SB^DQL6zpPpU=%P&o3yH~bMw4|pMq#+vOYX7e6FAJ8$S{v8=>%N>r&MR%eQ>?7 zZE?OjJBvl|*wI>bG8z6`xgZ})Iz>Bkp*Ayj+>5!Sk!+N%gH^UVW@cBPP*}lp2QBl<| zd4BAlQYB*3;@mOp3F6U^4#Tc-oUt8R@9a1$SUPJv((V9OA=m>Qs0?1nN3^C{RCxd_=Np7G&_cAb)vTDDwygV1W6ar^^Di83IiiiC4#$i zMF$s8&Wz9T5D#>0SxrAK&RsP(9G+PkJA8~MCfRx}^Neh|Iohs@rDr^ghAjPdWmB;C zMBvY|_Zxj)VM}Gtkb^HeB@5Nl*OyN%uS;=cm9yVA%vYD7FM}Y=*ub%<#VR_hfyN+v z!m{TXFQn+E=U0O%RknqOyG`}9wBoxZ2@Z~nzAFiAt}Qp4I-AT%n?$MhV%uxTQ?rxH zXIY!b=jju&g!Nr|963xcj^PaRh|1*6^K*+B9N_?w4G0QEigip1dY-gE?);A9jaPb3 zB>}%H@R#XFzD2qoM>rB*>(feH$k`X4nvreE)8$>K=0^{Z!{={0aGJYF90*NNy{;9i zji+V>%W2um^uvf1z0&8P|MI|pSKxmY{b)e*nMDtjS)H)<{j+nvl40mzb^5{TNiW4& zXobkb6w8Ovj6Rr+4i2RmzvSx{5>%+b>gaq7Z$h!KsO$kY=t7*w+O=0zi^i#R0BQyb zV!>e{rHLALDWn2Keyc}*oUY0vVNNOW$-f%hZ585f+bzAh2@mUx?BfKoV#I}b`LD;a04v!Tn|gU z#MKW=ZYPbjj1l;mZ=ZMf!)5*hu*^RStNAsL*6U`U<|eqT*UMo)1RK`t6@ZEVm9SyG zZUIcZx5BbsABGL5fLZ<>uwnUc1kCd9gk|~v0X8gu z1TgdckazEf%lrpmS)VtPx}_Q%B%OnPdsH<;=d1;@Y`UC_pPvs?|%51 z=I!3C!e!cVSf(9=WgRA9H4pcQnCA#A(;S8+4;+Ohjiw+jUIUjjdIv1iPJ4I8yX0-= zeJ3pOlV=rwOdA)FK5Qf9IAPY4cprex;yZ@0D`1bqGR+dK((DBMtmjEs#ytqD?MC0N zV_)WJPe`wak(aoC#JfN0-8x*BbsCmsy$v>7=dB21otyPD@r5*aw};;Y_od$d2wax& zE?C9=k|Sk9b(i`8mK^UzLl$h%mP0qp;-t zkHHSWejL2=3|#WcFToO@mixGef7!dAgv)wpIiG-^bSF%n`x@L(UK|8We9h#Q#=RQx ztXBnA>-;JBneSI&8TTu&8ux4PGw#=6S(h>_;opEItbO>K9)1s8#(&1ctSjN)@-X?H z@RJ^Xn}>hf!^#7n2CQ}X9iQg2-hB!#>-oE|n&xvp?)SX=`*4}&^RT2@8CKIOueKZS ze~9#~=O4im&mX`N&mY4oo z^8YtJ?Z1Po`TtuV_V0syUxJ_Y{_kMfKg3D+zxVKa;IbZn1*>KKHT+ETKfp5X%doe? zGVkkQ{|5Fyz`hEWVVdtN@H5~4?A^cf?*9Upc>WeP+pho3r}^K#`wU#xlf2A4Uxj6! zufu9N|0nz`=kLAyf5Bzi{|FnV{cgbj33dnU8Q9BViTfX5IWGS*EZargY}Y@+{y(s6 zS6JRR0kgdS&%4jUWqJPvHY|_jFyA`Ze}Wx^eGV4pw&(HF4@>x4urxvZgN&zPe3*{7 zf^;WBJcyE29NdO{#1Z5>8JmwXDaiLwY(Dml=41QT2Qa+5Gk7k`z^4e)gzX0??L%8+ zg-X0EL(73TMb}p0NGJK>3VwBgSJpJdy8*UU{#N10BKZ|x)(!h{D2@N&O#7vNNPk-C zuo3Cm_p}KA5r(s#!>~bpl7+43v()1-q$A2jk%hFHoJlAq}} zrPJ4$Uh^}a!Z(Ds1Tef==G>Dh@5i+HVLg#AJNT5z)NR?mt?BZ!?GvU7nP*!%{kt;t zOQlEBj^(o(l^*cEA;d>|QHcoRWfw*3gD8RFO8YcCNS_*%#CHK~5T9*t3P00dm`?xh zuzrY2G5N*9eD1RKZm{+(x@9Kg<~_daQdK63ko6SSrmzY-VDnV@qICL4GF8?l{y4*l zpYuk5e`_Xvs)@;$4_ZOwO(j^~u+nCQ19f@hiup7}=qg@TjEZPbu?F7wu5`RMO!3O5 z7?MQu#wBTdS>6zQVf{F%2lZ>q8{gA{H{2Hn%M8MHza)+KCo&z9Y8R4fdz-ppeW{!U z_5I0qc*A^DID&i){cu@2KHCqn`-mjb{jf8QFWV1-FRWiVoqlEgz+(^K0bU)bsd^)- zBYiJV*CR{c6uz+jSETbb(D%x8e3rhl(~2Z1`jU@cn$DM{qvQ+gaaB5fTRJw#I{o@3 zMZ#3ofIUURu;{DPMR%+!b>@I2vocPbmdLnW>GWGOte+BL>CI^sPN5hJHmRFM>t;2| zOf^{Hu;JGP6=R=W8^G}H&Q$cW4E$cgG^_{kiXK2b*TDt^`l(F5l-`1*DdiD(DZ`dlzM8sr!;E#d)a$f`Wd=6RcIdRD=zq zVi;5?%aL--6L#bc>GTbR+MAA#C6ttdtSchajx3?%!bXZtDf~e>N~c!w37tmL?P?HS zqv`m!hYUhG?@Px&8pb24ZTUg}G$?xe(|EJ}_r9E~csxvhFrEHGq@UK8_$mPmZv&6MIvtGVIxax@-ZP5<*s^w*`+|AN*_HPz5nJgnDkLB61Vc^OvP z8RYK;hLwv(q`~V08o=AYus@iNk7ZcFkF2d2_9K}-O$oXNZP$HLmSWaa0YO2^tf_c( zx?K2SgKvioI;)|h2kw(nn@mCpY8j#TfbN(f5Q-ftD3^!^<|%Qy<| z3}ARWaluDJk*Xpz;G$j-c`|LV?RTZy-nMt5=1wAga~kO{hVqT^Ka`IDST_Fdbo|G& z@%Nd>d>m-8#z!V!S_%v4L`9>G%f9y*(Y@ zK)Gr zn^kfJZ`h8*>GY2ipW;^+LA@YZweM6hS6ElGN>g<;zNxD;3TO~@tk5QXg|ww1k12lg z$`RNg-!EtT^k_Q1?dp*Drqb!RhWHRATh3ZO;HF2#2ydw8I}jGs^OGL0?9d@fcj{E< z6&K}5e;{7_Md`1+s4IHyC*9H0mA~qg>NeEto#}c#k!i1%tNpCyHQ<>}L zooCYNKb0vrl^#h`^#|Ng{%jgww)|fS@w5E7Abrp;S?Tz*VLoK}AYmHvq2?pL`2dFZ zSHpaae;^(IYat#)HMD0Toqo~ddtbABnqOVzPnNrw#*?MXr?d53N~izzX61$WkEPRR z@uzl*SfArTdcqF|FuYm%r}88IH^Taa^goftbAPs7CxdvF`%nPG+o{~&49gAMe=5L3 zyblL(1m4fI!h1T6CpCw#oF7TYcWoyPXl3ldRh|?X$1;BuR%s6JZ-q1loRWp0(N4xQ zUmZ5c_qt5J)WMLQNzAL~- z{O=B6csudR?}p`sc;A!8)6l1nq~p&@pZ<8d%;-M-iFCftX4>4T@3Qk$(w9G(#=Gji zd~bk{efd)X3~#5td@9o};Thuj=`@~(zWkYV{8{PCN7H3S_vQQ2`Cgl8v*-Y9^JD3B zpJTd^zu%vZ&+1w!U4r;NkWN29d^(O9|FZ!M@8`4SeJ~y0&<7t%#~0ZL3156TU1o}w zh)T(vEDTy^$4xRWelCr7)#Kvl1AL_QF9a~WoyNuQWq3r}rFvT;`#+M#o8n29`_Xj# z*07He6{T;3ZYjMP`J_G}Z~kIX4$J*m0K?mphGI*3dBpM+Hz0B^(o?i1=eT|{?kZ&Q5^`BLK|z?bEZRDHm|GX8_~t=ijGw+Y&%yUo&04OcfD zFP}nSQ0^aO==O&mmWQ_3Z@-dGpB=}k%}PF1%srg2ykAY{7rYveC@Bwa(|WfG*Zi#C zufb}22!A?&;qBC~f5i6EP-j%U@XGom8&3Sc4y)zC`^TPMnqJp6GAANl-4uS}`HeK5 zLt#Gz_&0^&$fEd_UcyHRZ@~YXY5ac@;$iupNyq0Z2U)fJhH`%^jW^XUM5XG_dOVp< z|EFO+v*`iH&KpuM;{WY5{%n1Q!t$8@chc!)d}x0#{&&;yf5!Y_{AU9g-dA}1(r&=o zew7E}g70KrMZC68`9@sC>;8=H2fd1TVZ=rJK@W=yxZ+`T8~W)fWY&7atNRdAKeqF8 z&Er4e@k%-*QM^Zexa`MhxVorMB2PY#z@Xf=@+9?Md}?^6#7^oBc`Y;Rq7Dg9{9d{a z9eLvS)9K&Fwgzoz;Gw6}@vUV0OFYe#hT;Zz&oEx=9fY@?>zbs0cZdflQ^b2oc*eQ7 zv~Y`i7H0SC9RAZliq{+Hsce_HS3L1P&q@4g0RAvyytc6G&^4#!QBRf;%G03kZR>Jr zi@H2GwRE&?ZLYlb+EeoIIm$1WH}ZYabj@b3;l2w^xHr%WRvK~~`~hrG{}itT;aT~a z;t8Pm^JaZb{C}9nuj5e1*{8#NNSdN6^Z!vgf2w|nO4Wnu|2Uog3&gMOVEms1FuZO1 z>$0%F4$t0Fot&JV-hFs>_tM<%1$l@HlvMWlV%U<9!hf1BQ7NE3B`rV_g;TELL3AqJ zI&46)yl0sa2Ji`m;g9(nPtoj{pXs;YqjcE5QXM}q4D*&Rz=(7Uk8QU%{|ij!kuOe( zmvz4gR`9~z47&rChPVfuo798pyI2qTf|d1PIeF^A^j)lnXlSg*dRWphq~m&Ol#5Lw zUNpZjho|Ef#};eTwTY#<1tubv5^SEiAJ zb}x~w?pt7rmH{>-tQ=XKm0mZ6AI@g2s7HC>ZC)AmBPsYG0a!G%0bCruc z$vm{t;dqzw2KgbPULqmb?@ZsVdPS6*(4(8>vK?DtK^Iwp5q=SDM14}}yF~|EMWP7k}&I(r(Qm7S5&oZxt_c-e01`7 zG3v)~T75^>f0XWoG(SLhzU7b2wP9HT2J$2C*px3ziI@5#-S2|UHlT@aDZ2xjK3gAj z#EN7E@o{dT``xfgAQj!6K0eoaQzHoH8O|l7Q8<@qN4x~#sIPpSuKC-{2T8k`uUqX_ zJVSLLZEy1SZ&Ke&fEVrjNtL~vWAn6^>9wAvIsll}^z&uNA5p&SN|7I!zMJKfCy2KU z8_j3_GEhVe>?>l`c!Ey7bv;Z1c!!YK6|7D6p>KL^lYS zM7tgqb(7;$#mBV7#~!9(-C0+r-wm7PG6bnvQT?^NCJMz}Ix(@H*>aVpaC4Q5^m4qZ z_%_$I`q6IQ@}wOoSLjSS-T)gz@4ZN;^(@r^q)o1RWXo$pZ#fRq`en;qExnOH!M_LX z04zrjEN>rdp87F;x9Z38M`7uXz@lD{Dc>Cc98s@iG0XJbs#iq0$s+hHmz#{sZk7wW zzfbADA9Q4Y+!)ZGa=4wG3*{R(iJ1Q;Sm2c_UrNtbc&AO|^h;kFMb+cTO?H1quTj7HI zA5xKX5U|#(m55N4s+owWIDD%XHLrGfVnt0tC+6!`|76*!mqg9?I{Lj3MNKj-lb5^2 z3pyrZL|iw^@moF9OtdmF6QZ#De=df);6X#V~|q}TS9>HyLv zSG%@U`{hx;pO z$04+%8~yf1;K?)2-qeJC2vXDSe!EiV5!SPZ`z>k5ooGi^Cw=kZsp)C?KUVxXYQx6v z9mvtDr@7GYhgEHUC;Y86hPx1lo_;qenyo?G7h|;WA!MY8(CaNMl!b@W4h!cndowHw zlczm2|2BkW^Xo1J@yx=~Y=vb7iR&G(G!&_v?uh$`9Q<)*jk^JB8QJBI5{Ryr1+U=K zot1kWEZ1$agh}0?&PHZ#VJmwUwR4dzKJ@~Q7QU^{=DCg`QL|Pe{SOID8<Nu<>nb!KkUjWWMIA3;Z6qD zy@0ijD;ZckY64AqZeZ!_NXmaUrqGcP6_6#-_qmmCRx_sF=J==SjMe(3DJ?nAsJh>k zRLH0rbGVaH^>)Bo$CZq#s>9cFqiXr(EE`wo!ex_dTu}jlCII}A9YUdi4N(|4<05#=WP%V)XVq#wFjF6m!$^#5h0 z|B-hh=(>bEGNbWd2;b9%KN0&k&B54K1q(inO@sassn)0Ho(nQ zkBD-UJ*Bf;ZZaOva=FR4ILqZGa^NhNo1AH!<#Llfqi&W9{(nNp)jKgRBKSMuGp0X_ z<0|RzZkCJoe@fdw6W9Jkt}y*sY=6@K-7J@L!89!0IauxgJX-fW@_~->a-ilPL>T8S z-DJ8Nej22cd4lCV;NV{){gsY`bpXvxE;+6EhU(3c1);g{YWs$PfbHWP%r;#KyAzi4 zG3Q+xhI3wKTNfO>$hIO}uH$GOhwBLJY;x5TWynhfESnp0fPY>2e96I|R(KIG(>(~A z-JE*yLT!G!I>9gCv9}q%)yy2nVU;2q;SYOUw-t5QCFB6zvO9r1sM-CjiQ;)l2G13M zsaen^HHn8*=1qU%CN8?esnj%hIK(NNb66+MO|b)#Qe2<+``mEbsBlKy(?jW)2=S7zM}FY4o~hYD$J+Duv7;C1KOy~ zHRQ51JQr6~I6%k`O_q_#v_+bCtIdk1sJ(LKtvu7wkGlT*t>@ut{x)<;KA&VhZBMBV z0A{7Upm>Jrf~MV1E*?XDq`ulN$_VziPP13RAC7qnPLBCHEb_jNG|{?kU|?&Lw_ZCV z>76VWD2KEzrMj!gO6iS!PezuXeAm+D@_)No`MX@RgpW9Bu`hlMHrsBWj80y<%L7@8 z@5;Kv#Io91m#XmJTy0UFei^D2^7OfwH#v_|p6`U^ycv$E3jwnq-vtZ4OB9B81J2F? zEfoftM<=Hyj?OL3&CDHJL|$$GO6Jk`xVo%*9(}~&$vuxUpYmX-4ghAQV>wI1^K~92 z&AZiR#dAK*qd)HYF!wyleA=E;9RSQqc|q|MJ&z8ej-kv6$Ggs*I*q$ zbCXNW$@W{9%NM*VgH>N_Hh=$Q6S_O< z%WvL(PtD&it2<2naN1dy>a73fYMavXN>no(TUP+)n4(KMbF8tg%@*{Wf2regKIR&L zaJSaM?*%UKeKLRl6yWUK({ldaD(m36*`=x3W2>LOf7(@L)zkOSI6S$hZ|3WkD9MuW ze4V~Y^KP|S@tjZ7_oI#%a!=pPr|l`#0l=(uT2VYhbwShaCzohJeNxNdnCbg{t{tyE z8`C#MRVeZ(z9`~CwSuCL%ZSHd(Vow-UMezQ3_tU8`XlX+!qPBaPkp)MCl2Cf`{`0t zvJCEtUJlEp6h-ZuVQGkq;*;gR-@$U4gYW^C&+rep@Xss!vw*c;D_NR+(BWIPZ2OSI zlUueipYma;4giL9@HQ9U^@?mG&AZiR#Z$Cwiy6ZocKue!7}j>axQ;?#lt&!oemRzC zIlkIiO-DB{xp+Whn2sBi92WFQ%iM(UE+5SX5bd2PpiQ?H-2LhNC_G7LxwXK|2!hYbK!}70$<-9|kC#1XTJD)^2 z+8g~r`4dR5?JU&+q)o26qukU(6PxO3WF4SfWoeyX;>%cJ-*l)_Lv*e>YG1M+oAo98 zl>Ny5ByWfPIS82J=u@zutNd-0;%hSw1Zqdegl>=?Ky|&4%VCX@$j7) zSn7iKCqhWfjYa4vhrT~8@e1EERd=mI0`ZM8Yray~(l&p`=a=FR+qnqWDFMiAQ zr_67Je+O3SzmnsR-*x!@jQy#2u7`_7TaaNbh7rYVu|0?n+$7`3%7rYVWA1tVR!5dM2rJ(W!ua4)d>mcy? zX>!f~N>4pL(e;D6;U4}@w3l-4Ww4yTFNbAVc74Gx%4nvef$S0)O`d$p!SeAJ;m9KG=eLl(5qL;yQr9unwJUki3&O7u~c@8|$6WCh@uOYrp6`!#Rp{q-7Xs z_jy=d59r_7r54`@QL|2k8Ax)bpS8{9dp$a^^tWT+#&WA@&7g~;I}FK`+&3U zAz#t3J>;J-KhtOH$8_H2s$aI;UBE*_Tx>Jz`!sB}JOru9RUYyE9xU)DJpP9c7T#w3 zAHcTJkF)yrpOcQLYoc!xAC1?yCB6+l=@+)u>+_xPeL?%}kC8{|M;$HH)2;waoYbG# ze>-8xmsi8mkiM)F+xsUDemC(dzv`cWbpBget$~h&CYaGCRF>6`J zR+id(D@zT&l|{KMyQNhQ%j*0^Fdy$S- z^Qk+Euo!zI(y6@({$}>&2v>Ux{4w@bNJp#r)U6<_mHl4CHM8G`aJAnLe~jfW46Wu< z_w@*CWp77ZGkXZ(YTpQdjJ*r#Xf>a@Z$?;*y$9*k^4Y$2_N|D|W5!XIPjkxp&9_A%~(oOTK6+t~*Z-^xCOI9hE}Ok0@dl()=xI@10a(y8r4 zgLfhAO6^Y|Z;btEq*L3eK0kxBE3uvM@{(?h{SeZ%v%Fx}4f|2xX=Zt=g!bcs{RI3g zu}>f$ZHSBhR|Y>0YyWG6sr`5Gx3m8q@y+aCAv~}BGV(OD|0BX_|EIue7~Q{(wErv8 zsr@SaG4}sJI<@~1{&x2NM!eep41Xv44Wyy{e*>#wbpJ~S`z^$){W|>K=Fy{>mNz2? zE=2xKuv=lvl>_*NN!%O1MDtgb1Bb;_MxWY8QyIPFBQPJWTu%q?%|2e!ODd!r@%i`q z_>tQkzC9j(sgGB8w-2v41eI4Q{Hz324%A)!ZV;!hqIj8l*`@JSEfbw)gu z`!96$xX0%|_DvT)UUu%nU;A_waq;8maBp4Uin{ky(s1n=2fx*a&pz&8s?so(d(Jrb z{)~IL?!vR~)Z;Gv9nUy-`iyhmRCn&{#p$cOsp8pfV)Y>#Gd2m?yqc*$!lvJ$+~8LSnt_ z>B@GN_R!ZVTRgud<@@?<@%gl#n*T*U|5mBiH3^>0tmUqMs%-YTpn|%8>YrGFvIwk3R_;zW=>nd8`t!(YaTPqj&axVJp?yYy1E~#8pb?sf} z+I#R{T>B3Go2T!9ug7NJu1(S%rz%^uy=>mMzj*LD-;Q7zKf3xeS8$3Ps`}W-U_ip@--tPEl)WahZ ze7G{=`*YN%ANf~y^r_0omtFslypx3cMrGd#hkw-5ai7PtUpnTCmAzkO!*^Da$wc#S zPM5p)DPfq(UY~!rFIOjz-JYLDUA+*y5w`47$*&4%0`${pn7S^s@mJ&3&8A>Djk*qU zu+~HKX47ce7`GFSFh1jNm<;=UeZzDN3vCz|`a7jze0GBLlVbD9aG%bB$*c(NrKt{- znhcXhl~5q9R+1Hc-d8$O zt1hU2qPj5d`liI1P{-=8whZbP!t7 zpxv;6ayfvS4lM}$7bu3|+>VwlX`e13M4JPvt<}j%d0%mCx;kE)c1ZiFC!>c&U*_=K z4*RIqZkdDw1$k5C3`tvrU%E^Got<5`HvIj|Y}(A1ux@`7UpQcbv9s(A$4)E%@|bGo z3&&Y2e}6Lmn)$*p*~;IdA)VMZPm}UgzEw4w_EnR9i5eFX{M>>p%l+FTK_|L3mj|t= z857=&b=rru>W`T4W^C3ztW}T3gg5Q=W@B|ZtO-vv8^6n8Q5@4sszz`Uuc$YZnA`U3 z;WcUh?aChRJaA5V6mtsaL$8ITv;v(ASGw-+VZ@lbiy=ktA%^Z*3@LgKF$PIb z@oRy$Bk#OL+>(!1TjSnC+>(!1ON!n@oE;zqt}9zkE^D>S?7%o1?R=q>nH_0ogSIb} zGOwlEit5%g}BdsOl<37)2%-=HaD)s z8ayQLq)q9bsp|N2t$e%OtaKCHa_DPX&UDSwEQdD7*E}>Vr4xo1 zO4{^{x=fYM?O%D$p+j?f%9x+`BvW$v4VaIY*J4`^l@HC$?oKaPhp)<}x~fSk!`(4u0IB{xbY7-CwvwL0oJ*_?bZ?zQ1X} zhl>nN(mmafE*2mAq_Nz`8}P-Zi|r4V*;wx1CFKe|{g=V}5bEGP?kleZ_Madp@X`13 z^RAC3@cq}M;iYE~CC1_NUv(nH!Ef=g3Lma(fQ#QEUjx2BN$$?Qrn0#&K z@|W(BuOO57E$*wd1RnXke3h5Ld%rFPCb0j?4lp;R^kFNxuAUCsFnesKwlFo}Q?|cc zoIGg zcHS^=n=m1`D(=hIx^Y=Gg5d7vx=Xp@OFS{<$PM=NSk!TeiZ+f>26`hreejzKrqUXY zH0_KY=O;b9ep14`dPVRZVc&Pa)x7Az@3(O=Q+WGwxYQ3WhUI*CDJ5;hWJ@em}{QL z59{M$eT?x+hQo-9_?LQET)mWJ&h&EQHspJgBn(#mDyQk{@X$F#7#ASMrhh7;5F+KKsv8dj3{FM``fDdzlP*XR;W)>*as$IlyGGo7*E~k;!84naSb?J&LmUTIh9@ z-=e2A(~GIEo(;XYjB-Lfn7VNjJ@`86p@Cj1^#YbO?QOMahre}iYkac-wndzCJo9USe4f2d5(#_WV;Gc-O zN7m*A$X>y#ve(x9w*QJTY5T7jlWq2$ZT}VYDL@w4{wwI(zu%@4Zngtc>iJLhk4zrpm(Vq}l$nV@Tr>zQ`v z3VjH@()M3L2it#5Xkh!V7#2Lojk)UwzOg%3pjF1?;UPQc_xECL&F?L!D z=I^-PlC`<5`TOiX>GJ-i>6w@$P0vhdkVi+bbAHn^Gb*Nld3eZVvB~1DeBT8bE@wIs zdZ6vUVwe`72ipEC=-T7^uXfIlKD0Hzt@-&qcAGs9n`;7DXLtMi`s{mt`<@>|LiQ5; zI|im_f*z)4k}H<=!cv`3vfn~}$+KQ&db`^X`tgpHy{+QjHUUrA-G0vxcIT?;n>w;K zH(3lOfzdU3sZQtxFN4<4{JzpeRg&EIy@f73IIp}(#9z3jC$zpeQ>w?xPy+kY)a7TGyJ=&E}NJ^Hqat@+W1w&u4r zzpeRg&CmBrAq(W4eS5dRFZ-5>oh^Yk+Pr0AdM4=8?Y$oCIhdXay7su9Y2Wjs4>7k0 zFT*P?VEH~7u(*I_e+RI*oQwQ_wwNpiEg%c*z9r}ovF9QDWwIE=f>GI7suQwve(am^ zu9=+8*t`AqhF`P)$%3qvIVnQc$Xr!`tP#8s<=a^wWLg3Aw{w2b)z0~&^bMIyy3K<& z_Ca9I`wq$F5@CNj3Tl0es&?nXA{m#YK{Ggr5;*N7+ zq3e(ym&JC@?_{y)OYn-@W`EV*?FW(CoOKmC)*@t`t@+VE-Cl2DjptFxK1Xp?2r07+ENL zRuOZN$V`*P=!D`;o_#ZWx8L6F@2UUDh>$h5=7)?aK-SutA9S@fzpeRA&usa2qn+~? zBYW+f-^*T(J$`?+-oy64sU6QdZT}U#qWfi~Ish2ke@$qRXT3%G+ zk3Ph?zN~5B71z%BXBTgqovfVzLHIox#`<}2)?sV@j&ppWXMHN`?A?BQx4+HW*Yr%t zOdTtwIsh2cGZPw^o(Yu$-&Dr#x7(T@wBmlNt@#su%+C2eKiIqd_HO?U@B$6zSpOe7 zA~Op(`&tXK*w*~u6I=7!8-DhNpS|H{Z}^EUw0EP@`2Y2c1mMTwI)* zOPv|;KB;}r@AOO=Bk+m~y;IIo0E-J)))aunZFBZyYkm-^&AzkU?FW4dkVSUR54!4p zzMb>0?#@*iw7eRYhWj;JVZTKHhIhF9`=#Ft~!^oh`W*YsSYvd+%=?VP`jz9llb+xkYt*t73?AfviXcg)2yH%8Fk*8IiL zU)FyrdwW#Rv^76?1A3;d`9X(O+GdekH9y!Q$J-uu z=L-B2vFBmu{I#a%m)w6fSqvUBSxiZ6vUnA9k;!84kI7;gM*5RSpP?+?Z+jFbi%WIK zKC6&Lb`}N_M#v)j76Ej!`>##kA23-A-Y~t`WHBkQin+-2V$d&QF0ws})_W8ti@`%C ziz$g#C5uci2K^#rk?F;tlj+4x_2L7zM`5zKRL1~;S%qF`vKaI;S#0-pWgxkqy!*u_ zi$OQjiyiZrEKcU5JmZLSnC(%3g(Bu6+oNc`M`5zqWN}}q4kEyqEKX=(vKT5#jyrvJ zzt|0-@HY<+@gBvEwnt%lajEWD$Yim}V$TD4GFfc0*km!rPpOU{m{rV0wqFeT*?zIGk^bbB#W&d= zh3!$4>W+O@A&cxD1xOeni|kGt=wx@=n%-$MSq$E=dlV*%Nr6?&MWz>nei3t#-J@uI zkHTazc*tZiCDE#6k?F;tUxX|&y%=;dy|}4fe6#IQm@F>UF+gBep%>>foRf)j5Z9^yR;lf@>B`$}~X0mfu;LW4Zx z$Yim}VmE-&zqxp52zfVG7xzpYtu9n2mTC)tp9^fW_-0|ubH0UZJ6hGNMV&c6z1;R~ zY^_kLgQ;O`eoAPNOSXV+cAg3TiP*QY^UT)gnI?e=`|)-uYu z8kUAKVJqyn2*3=&a-Rj}I@Fi4Q{f>G%Nqd*78mi-=YYipEP5MYaRI-S`C!BaEMp0< zxPTS^1wNg?sF#!&I~ zIvLA=#RZ(z16%2J*HF)k;K6gH*O^{}{wZqgNA$bxXBI<$8J{Y9FR!DJb8qtMnI?k zZr)zTM9kx|UtGXEE_fr#FI10+DBt#%F^&r8e>+*JPxn8fIHm*vNbe_W&4>44f58X7!Sz}&kQ*3c%4O&0f+>L3D)$>M|tdFLWK=Li2p%tdz2-})UU zlf~d6(~BvI6FEegoL3f^UJUw0$Rg8=K_}CT8}{?;-6(q#uaEbN*WqNo!*@Hj{~9N2 z?Q98jD#+x~4@|b1Y%|%0ffym%O^*hhdhFcX*3jrPTSL2<*7h@#eS|zZ0{0wjKNBnz zv4>#$nYN#4-;iRgKxWu?OQ1sm`)MYNO%{U!DU)YDw>R4XJi5QFp=}LqYiJC_QXM}qtJp)Z{Y=m=LiXF)lASHt*^-krcD4jM z6rhKiEH+sT3Z#tb#UKavCq?GKD=uJ@#UO^RT?>#!w%-T(M(Bn1-4f_j0ROFp@A>U) z3A|xvOLn$oXG?v3+ncYSlY0zywzRVUBq>A2*qeCmWlV$~V`odn=rN{8gRVU$+w8j~ z^cnOvdlL_ISjE|jjeXEBV(zguH0We&=%#Ofm@GC~+*hiD2rwp#6B^_>7f9BaCX3zw zSGM_&7dz)~zE5FyuI$d0-MPXXRI1|#W)*Xho%4f!5p$8r;?}a*&X&MKcDB@h-xo5< z-o%TOHFmcjbSlW?S*zHac=jfqy@`i`Xm8?moZCc?wzH*`otyJNk3qXW{{KAxN3IMT zo}=^4-EYCt48lGqKKCEN(7O~KdLDkja@GN_xPa|`CWrz3OXyL+-oBkJfxZ!INIP2s zoeJQ;wQxVv&X&L%kkxk1?_{;^>E&6kBr-li7Om+uW<>i<7Mm=dU#QtRKiEKI0c5YN zVE~J3vKW+rS;g6k>BXR*$znU_mx1Jd^5`?R|JqtM>z>C2-1DH}o(N>sb%Z0voa~i! zdo31GuHEfN|8$$~y0;TS|23`m_t^fcottAUG|@Xvw#`n~PJlLErrWuB+?-~z4Rk8V z9>hpF#6D$;=*V_He*7q|_7Mm>YE7d^+7?Z^b4NMk8 zMd5x?Fa4*ruJL>HKR!$rgWpUqrX)_}5M^>+S!8ERpkIVuXy^Q(Qvv(UYvIn7?Z1LI zZ2z_6-EP}|jgz&u{|Y)4Wb)_-c5ZIx<~_Bhi_qij+XV=g0`xfhZV7bV3Cr(__#M&) z4-a{m@5M5HqlY(nc(aG?yCo0;W~KXzHugK-50o)l)Yy-pzpbIc-v!WrEv%t!KNGxR z`MOcuA6 z#dfv?9%>?+?QXx_?GL|gFufn+MDH|RS_g3Ujh!ul=8#n~pTR3GVBt-`;sWlZcbaT7 z*=Dj01IB;1W@k&Fg`F)$?Q0G39&)$$*dzASM7DRkT-(pIH8lA-g8ys{-FgjeXG`EA z=$*Eo2|BFweu2qilf@>BF@Vx0@0#CaG3aNq*fEjG;$%L`Gmbci+1V0U$n@frFwVn6 zcDKLvxxekd+WxEUze2S1@cyfvo1_1rXNsNxueg9swwY`*+19(VP5$4A>n55DVIPI1 zoHlDT$ioB1JH{`0_$5rscb*>YbMGAtE-qD<#`YT2XOu85!1uqo$3tJ=@bfSjQ@!n) zJjmboMzggWt>vC;`*e@gzryAwK!w;hCke!?TL(!Ro^7)a(%tuCFaD%q@6e7ev)wmMt%U1~c>-d2{TFksAx8CP0O;i^qoA?Kp#;3<75Brz_Kw8vfb*Z}N@B$kl zN>_?J`lrB~n0@is%uIFRq)XOM9hG;Q>GHh<`A^r%0r+4N_r@>L{8i<^VKJ4_r}oiQ zMlbmY%ttHN(}8=lkJt2)3h73C{=Ghab8r|;Ac0kQ!XFyoxN_qdTvzD%^6109v?hhomc`xIz`-d?j#_Xin{lDc)l#2%JI5$ zr!(;Q-O>w{swdv$vyOP`KJZG{saf~5$M^6Vhxe3+@A`~Of9E%xd&gfo{Pzz!ckvmQ z9)pCYa_kxBl67G!cb#$W{TI4=+~e~f`=$#YFFSYPuYJ0TxcG5&xVJ8FMcsQUX}I=` zgWu}IXCHU)8^!6X+;hgk_h;P0br+s>ryh6V?|8<$d}p(nnw@z(iIRfc{1 z;EspB_Sz?RRED1vPi4y^mpy&QKRi;|cHgdVf8nwF8r-4BB%+daH_Q|90~J2o0#g}g zF;9G@vK`1Sd-~4Gg~WQ<)0OQk?V+z#ws?L^%J=oz;`3=eHUEoz{;g82YZ5%0S<7Aj zRN3sy+3xCrDmXfnd_13(fvNQS`VV`2n|ymW`Sx$tcpt8GO49l8?b3|bRkXfa+1ib_ zR(Q0^axVJp?yYy1E~#8pb?sf}+I#R{T>B3Go2T!9ug7NJu1(S%rz%^uy=>mMzj*LD z-;Q~?D~J?og~~hD*H}2 z{G*V;T7AXIj# zYYnMqLLvSnHvAvuQMKjN1uE7@zSsOosiwzF|6sg*J=} z{hiV?q){alNUN1(1?Xp(R#wx571J=ytNEBW z%%|aD*m|VlD^>_gHEK}XGNPVQ^)xm!-{jA75`B4-$2u@GubS(?#7R{qOOsQJ^FBrY zQT3H37ZM$~|3TG;OAjp8CN%BwMfFu@ysvbmR#knNTJ5-Naf2rOj0;ctOm&@jjaL=| zps8%xleS)^?cWXnol@uXVBdXerZzcMojqONb!vX}!0GbW>mMwin!oA5>1$jC)=jf!WHhNg?<3*LzG?KM5n zy#V^lmsHxHJ^Jq;CX2xv829$Y6X>uCStwt%M#v(OnFWkRlf~%22>QQ_i-H2^FL)!$ zx35o|>l3CIFW)>hS!}X+HFJ^a#c^|i$>P?s*uFjm51C#JBEXnloX{Ze9*N0f@Q>-m zGK};m4-Zim}KSF+D*2 zg4el+{O$5VcbnTo1Gv$hcyChg`a@%L<9adu|8MVIz$81WGr{Vr?CPrSR;!T&0%NI5 z5(r74M%_|NLOhg!Z4ed(;vr!kDzYBkT~L)(s?3tqG;ODO7_fOiY`|c|!v<^~27xVX zz%qEev$OWDz2h0Yv%9Qdcf7k}yz5zHe>1~3X#YPV&aJpNA9Zh4-cn`p$M;3XjT>>} zapJ@uCr+Gub98cQalT=(@yV(BQa!pcx|~X0PLjPn__?lXXNr3bnnGxHB9BaQy%`wj z;a~-1av|bwyMVY05$`5qUcSvmOo><+yAni99dm)MIhH{;e@dXgE7z8R0X4-H7K4X? ztup@t9dyi<(4ffHk#rLl3yVR4lqgM7kb&qKmuVR7JrA~+(GgA@cOks>sd z$-&yOmgHivkgzzRL6LbRxmf032>?eIMR-V9EG(A!7bZ`og&(+0tVPmMfPT^!J2tW( zVKFEHor620!lerlcdzy%?n1=f+(F!h(oujCaGSs)N9P=KQJ-!Aol7{oa{Ia*^xx6u zfdhVaCv!E-jSkq{%}zq5xS&^$PqmeLPM!m6WG7M%);pQSuui79Lqq&Z^&xnEMVp^< zSg~9#cBUGNd37rbYCF382pn%MQ)C$;Hx9 z5XZuo8l|HEEu^F9`cI}hy90leprhFdXLmBi1#fhalVz?}pPjpVZH?I$a!-yuuuO5w z!8*5pG`UlzxH84<_j;ORZaWO>cfHUB2-|=eIq1Km&-w-l+aRxOBU9XKWs0j~u1X6S z0w>jKLIbH*rCRlqV&lI>c!*z|5f+2iI_B~WCoC2g2OcPbBV5C`#g@oK@&SDwoKVqMF8^cS8{37@0;@s?ftsY_{%SVqT zm)F_l?#Zd8>4rTpIkh<7u-N$IRDG!)-56a?B`+t*j%>r{qDp)aoT}C9WQr^EuSyFH z0k;X&qC_mvFNcV!H)}zs64WU>;mulMF?a*ZqrQqOEZ)poq+_mpYmv;qx|@Fqi-pBQ zl@^EqC%HJGK@l|`=_V`&|K!*g2#dR8vA&869+F&4Bu;RM*isaWq@w`+a$u2k6rhuI z6phCGQoV80+Hs3aao0=?q@xfPZ)RU0xj5fiB)M2}u}pD2);jsM1i3_VaXu`PTnsvu zz<)d8>`tb*;0@>~oLqxT7a}fmwYB{d<;87b_MSrrptYtPtaI~Xkj&L!BPMJUwgJ1m zsp7%T`w?MVFy+pHt$NJ>^Qk0P|;0-IQigvFqru-MO|@LOa(7Z$InQe|?mIV{pKS3WG# zF&F5hV=kG0feoChuEVjGuvl0uxp<8SipX@^=BU7q;Rf{IBJ^4W_)j_t5CLuzdvwXg zpkIzXy5wTeNpi8|Vz7ba;&SGKuvl1}XD!m%UH7v)nX6$Ab_&@TrT>6i<2(lJ-ZW3DUKlZ!6^?e@c;4^O#?abTAVp}rV8 z1YZg9-61|2;(J0I|4iZX^N%r@e{YEI3vre|0e>kx9qTy&{~#l9ERQN4xF@2$uKo}o z3vu@rK9XFB_PO;JaTg-)umW)xBEH@iXso_-SUz1)F}eD4%sJPte)C+8dR_nfT`$JN zm7Ak}NAD8qcje}&-;Hkx^=qxc95C~$LHJW1V3W+LFlN9ynYMxsTvLLVoC&tzx^~df zWZkboXwMHi7>*@+)XLbO@d@<^+5!cXCd2kUK9Aa;C|JPQKfK zTq!IDeTBsd4T`Qs!ea1`uoy&Gb47SaU;NhVwDC#UL5 z_2|avaw>T_Np{p4J{MHOX*wlGSy6d3mPQqH&@MiqK@llMyZCLgvl#HxEn%^+c&O3> z5#WTy2@QnB#Vjqhg_dW)u~-(Zz#!~Uq)`PO^xrmjFR#qCS$=bkl0_@{!>~>ktwTda zto3C@wfPhD9H$wwX2%>Y!J1zu_n>PI{*y&(_qSN}b^&+@a;EgJpo8}O2@SO8*Pb6U zVpFaN56Pl+&1y!G zRo|ZmFF?-J*%IiWvn8D^?Ub`6S+vTc)l2-gB3D{IzR}&ZBrE^VX+2IA-6~p^WR-*d z(x`&POQ8Qw(5T9y6}%yh>gLt}tQ|Vt0tto1>#l{eH0W+=Ad6Oy#nL)}4$?YE>#$R_ z4zRA&$-T!mSy6!w8`U*P&Xh$fEwppU*^)E6%bCJrVewF<1tP!+ixV0Yv4A1nWJLx3 z5f-~?WIsiCNZ)7;b4dDE&pyIpVR7JrA~?deXj@p>*_rZye%(b@Uw|Q5eN~3WK?mty zrGMQ)`d49_unls8ux%Y|mmLG6b>ynUXUD4-}D+baHQ!WjZWELs?PDifRP1 z!%(G#A2?xgLW3gnh;-AQAN->|znez(Q-p_v#lm7?F=kGsg&(+0tVP0N&`((G*vNj0 zVzI2gKso7OrGJ(Fb;s#ng>Aw%$XCKPVcX8aHpnX@{K~;W__4s>yXtl^X&1}kV)x|K z(sUz4Mkl8h=NlFqpPZ^M)uS7u%cU4c8W}*b{TL6}z6PtxTieXwC4s2x;3&I@mnl zJF`@8&evC$RvVd=eKWP@+=-=?`I*{6CaL>FTa~hJc7EpMQgdmsL%Vwek#LadtO?9ZGGvkdgk`n zX+Iy&1a{`%OvdcIzqYV^vQ}SRoCDu(JS|17k@i_v={&p*B5d;4g*hb6bzl}&+hQ_ z-ezrjVQy-AY1aC3mcP?zo?2LI%sAj|VQK-rvX%oOXRS-4^Y!IbbTDn;J{+>{Yfdjr zHC7iFYb#dA_=%?7NSc;_>)65)5NCeLn7}}HWM%0tU&W)bE@g0es73kXoafKY&e!S_ zm)&w?;`^=lP26(zZdD_j_Gf$d0&51PSW0@IZ0A`5f2cQBb zG`8QfTx&MxR=}t1L4~#Q0C2d4pNHW5{bAl`?MZ>053|R^>=;4J<|47>@bQ(}VwkZb zlsycraXG{|T?kq228&O%7$q{EtlddV0~mMc`til))bUkL(JZnUQjVUStIf`tM0Iv! zxmK?OP^Qwik1s7X>r2hK^zE~f+YvB5I=R`oto^m=>6N)V=RJ1#Ht%aJtpX7tU^WeA z_YqI0jxVh&CJ+kznq5Q9ee7Eri}zS}eW{Sw78+AnEl*gX`q9wUb@ zUw7;bVT2Q+Ls8G|R@C0pbyvz62SQ;wvC)@=CwP5Pbp7J!`Wd`NqYp4-t#Kn0(IuNO zTwm&teYCc4SM3y57o$#^ip5oBMWrx! ztD($}{WSz>r-Wb9+6YvcnOorQAr$`fQ23n;!$7zriTe=;;tYQaA^%GJe0WN;m%_6% z{4)UFBNtu(zZ;%uyl-h3B$qZ8()L7YTvGWQw?BN2#IfgC-^K6;LU=Yp<{<+9G(4Ys zLZeEB8^jW}ZjGKMtPx9s|#NKNaGSMabvaH+#JVOokk223=krJ5?Rk5~+I4-%a~(pq z>nZT>hmYI!RK!{S)8ONF-GDgDeL6hb^#S;}T{j}m=bj1Ac2wcB^*=kLJqsc0{~7qN zz{mCf9O5kJIq-4)KZ`i)e=a=h|0;Z^`hOnxS^x9kv-Lkeq}_~=^-se84SZbx3lV4i zx4_5szW{O8{~~zS|8L;q`i~&a=Uy7ZTM_d4WAJRxOW^H!YgcxD{6fh4GK9vfufR3S znSf{cuY_m(Rq!nLEjCW$9*J@GtPFh+&kd2<*nl0#qf8+ zGfxxVXm&TQ*-mbKnRXYv^&4Zii(^@&KQX;tk7rr-FNW}!LfAscy3W9}u2;cl+k61` z*yc{-%<^IyyfMVzgz$0U`ppPg#~a|S>|en(+w;~Cz6~ME`Bix4eG5F>!*cAIJY!=0 zdk3CldGCa0J?{$fcOzu^Z-?JVx$h0-yf2jVo*w0VAmn*JLK|ai-*4a^+sFQ~eIE>Q zwvX`-g}Bx8>xf%>4HthC_t=*Y!;|+v0zU%(QSizG2+1qI1<&%V-g`p)<01S6Lbk)| z`53NAcgD$c-$NMV#f^xwyiRy!Y0pGD+f{|PHh&7&eC~JPnfBZ8miB2}GwrkRY|8{Z zno&vL#7&vL#FZ{>Uw*G&5pc&6PC zZ)sMC&ChQmjd{NXZ~XQz!o5F3$mjnYzT5NvZOHpC5!&#e?R<1@GSf9;W;n=13df1ve~bHfd7Bs*{`_1e?*-1{eL0+Awt&oAK~NrSP!4u z1^>_Rqwqh5hr8(^{0zf0{vbSElztb}>6jkpV_8wYyW?_@i~EnL>mT~!cBm|ubyz*POwqO5edKe`BXs3k zh;rSYhUM;o@AiDR`*_4XZ{=mfcpS&l<-b1Df7d?bKVx**i~JmWdffj--e)_<;iL8> z8@<41sr~4)UUG77;`HI#%87~7_?fChqjToW1TLXsuQw+aR~yZV>A8u8x%!FbN#ukY zc;fUCWLa97m|I+Ko;vJn|0QeHLBvfD`qY;;SUR*X6Hc?*#KBkX%mg$V6N^hLa}!Od z@+X$+)`IC%XD05ft;|!;%VO!Q(ea?Olk9xd$;k|{j49mn%)c+4zs3CaJktrjar~?( zj>{}_9?sPF%hvt4op>%g`Haad?ApHr>H4$%b4(R8&)MnxZ^*PSl^8GDQF^w&sq&fs+;sjo#_dB=ipkH9)cRL~ zwQn$$nVUCn3PYD_GK+{=&*Ih&vvNqUiFE#rje|QsTpI@znQAxU>(ck4bUU*2 zO_dk7|Kjv>ZS=h)ot~wy)3hQ>ioT@FM%>FAz|+wu5x{+@Jf!#X=>O_4CwG?bnq zVO;g4>8jUlDrM$~g|ZlDT}v?TvUL6f8P-o>Tv|EZ3C1ENb*E%gR-?{Thb2OXAjNs93ZjbM9thSg-8Fn523|+g>939% zgmk_-o&JtE9Z5awkH)8M5xFK^Zg%|M8P~&h982eaSDcQdjuXblAL;Az)3s6gQM)%h z!LN(T!{xi<_Od_Mr_^`Q{BMCIAoTG&?4 z4e5HaW9XiHO~}{j9w#uNuX1*~X*KOs8jgG&R1+T8KxV zl`eauJnDD>MWyS$A%-(bCAC*PtU?`p%{ZtK6O*Z=7(v#7@CF&Wu z;YCp#m+NuChhs=J2#vUC5FpPj8|?dw(|zwbI=R+P7W$HOp}!g98`EE!PX9T}D>sX;j{wirp zM;^2C$tx$|qvt-J9n+KP^q#vzmN%cye;_UoNlxW#^&{T#s2KO#+W8vXi`w~#P_EO^ zA;~m#CiA)w^|^fpeW(X*Yu$&?nhwd=L%c6~C_U#r)~+3IU6XCYlq zcJ5gJ+;gP!Vmkk)GWDkNBWtSth_}^WPnVai|F`4vS^rX$KN^=TI=(l44v)N#aXRv$ zJ;(Bvqc|>qCw`9Uccjxl9hZZow*IW7^EX0y@9gxPJ#V4$C+lsb%gNH^Gud`F)A>K! zslK@U)pY)B`6*2i+jD1>pYgk*I4-mFPd$(H-;LW7)Bo;tIk#u~bt+0{y|0VnxLmK^ z-;3*w`+qtrhvmLLisvZzbKS~4lP)K=9G9Pu zX^eOZ3qhkpOy_eg_~^OkW}ZvEtb?pp?-!U4&am!_A#UfS?)^ZP|I6@E`Q7$>zaO4= z<+I>eUWv!_4N-Y4|BX=`m+SG$m*RTja^I9Lr)^B%oKD}8G5wWvow>*KE$QdJoays= zW0zg0lCgYiy4+2V<=dk2IF`Q}#c{dbSl*lIm*W|h^K0pH+Q#zj>GUlb%Xg&f%srOx zOh5OWOrM<$z&^h#o$o8m7xVYK)9G1RD~zCik3)9VNNyGB18TUGApm#cxFAk=7rK;<#LIUi?9ZN335a zw(+^o@BirPNyG;#~4Yu19w^?oFZ<8rit}HZSBe@A4`|BX+F6pDvxygcofIwdUU(57v1o@(ZPi*{}b?r z0k~|_?|w3!-mQPHj`=7m?;Y`d6qTYY;;Hu7a~2|bz5aHT=kQ!=UPR?(`6JaH@UNTy zQT}fI?J3(t{W5K{>!;nfFrF`;!p*4OuVv`=MTj#}^XYO^{X$Zz{cOh<()qs`w=M~=i~G*M{!&}HI(oAjkxvS@W6%OJGZVP-TG&I<3gmHe#Z1c&tSQ5E=2l` zA?`xNt08V-+c@2ehppYXG(CiCAN%>0&gmZu<+^;xV&$F;_nkh*?puiVBzW>w+>Gk& zi6^Nq6Q!nS3U*RoE3!JXA=;4e#2=*Fur5#hVLJb-*w?5JZ9H^eI=vgVKQ_?JXz0SI z-20hs?T+sETG?b9c@yp#F)8 zz3nZlUrxOXU921E7B?Dl9()ZxYJZAXqWf9=Oz{MY_|r~f&GP>!UB1mjn`fVipF`FZ zUHSYUr=L%?4@s$ZF#p%n`M<^TtshMPMij?o&+)o29F`697JlG(FL-{k#-Uq$YEV%%-_d$I0=pI*bPq_#&q26KV#RP@QCG=rJ1=#W2!N?FgMd&T4~@( zmQsN)(i`UQS8qDiYn(!=v3;CtxaZdWe${K`<*9#C_(F zj=9^>fplU1KDOr!+mWr`bC$24 ztemr3C=@QDcgJg=tL?YY*yQMIGNU+V*2YT9*Gu{bU#MO@ldMB~eHm{s-XK5ZXqQ6> zjyv=Bt6e$jP3Y0jdfATy@Suy^fieCF_#Ev?)ew=^mu{ z0=mCid)eGNmL*_>A4TV;d$W|~QhsFkX!vXgI>?qzJ7D>De?pJ_p^TT1k0U(&&_Ay<@zG+X8HYU zH|U+v;}FVa`!9ko(jMmTS9@6hCHd-i78;hnpY>mi`dRMd;j`n|wq~up+@FJFNt0Q0 zznY98Ov-&+X!;Wn7HJRj_p3eGdPzdG(RqW&%Mdrx+FE5F7w}7z`;dUYw2uaGOgc4m zqiYq*BYrcarqCK>Yr|t~ThH%5uP)Tuw)dCgA?qy#Tod@&+mrBg6i{CY&qlrko{s58 zi6{EF6KHWiwH4miLL!_|&&T|)bvn9N2*|D7Y;&iDjbO%&6hVP)jTgF6#7VR#!J}>N z_|(c{UY5rZreoXLR_4DFKFejeWo|?5xB5B=6fd@giS5kRYcxezs9xlE$D3B({+2aA zcUZJO*ALX|=uA3389ooauR=a+XQhQm+7)U?w!RMZcE>^1zHGglr8k~W%0G;LAnuMH zSl`v~McT*w{c0cUKMK$A2t3;LF5|mni05cmvYBQ6ezhw{y~!qci|bA1Wk2f$-QQ_+ zzXo*Vcw8INpE%qL=VE-Ll8Db=2aj@{$(PZyTR9gaFY&TdIoJDgoN1Vq(*w7Xe(SztHHAuy=83cK-OOoB5YMerh}wVG&kl{(dz-N4*Kz`dKf@c0=g@(-DIF z?>ES~5pio*H;6EisuM(1eR-RPnrHfQ@{ zv@6svYkv>^cGmaoFWZ@|7wsMt{&xMa{%&TxZuWi7Jzmf6KsVen*YELiZ_{$T*vNk3kMeq?3RM;)KXf0TAp?B0SW zx{Wk9`or)h%^$*bH;LiJNW)0Kkrd6gpywB3tnx8DNQf}=7FNp2<7J1HbDF&b9+kOI zd)V`5<6ic8(^9aUIy~J0cs7t_y#}6+kjmwbWxv$NKWeOTE8a=ZeJ6!dW%e~U-0#mGO=Fn%T6ZN zD-gFfZe(Kds0lO~xQS(7M>77?oWei?Du5-q?YWI_HZ!MQ<@u-Miq-u~Q&w}4S#`Uw zsgzkY<;zZH)vFP=Hg05A)qHsaH>=jZoTYh%AzX8X<`o5?S$N|huHT$v9gaW~nUndA z=9LyAaKL5rh3lWevuww-FXJ8)#Ev7Lqg{z^i23`~t{n9y`sFRIHyMY1)=T=&dHR3c z=zk)j|GBs}zTjA&gr}n+DQyoa7m{blKNp2-3dFpoT?>U}3h{J&eh)nBWI2eNPWph= zO`Ch%cgMI0oo%s=?YS)^!m%9s*s-2GK6<7QzoNcRSR1*S$iXMc5jgW(A1WcjoWVg;^PhW75AMvjTg`4ZULhVEy?n?!%n+iF^KWlv6^zqMFyn#6L z-36ajPCaU6Zh4_L!#Cie+l>Fbflu5CZxq>!>v+UXt!P@8m;+2@cQ>9v%Wh{&tenSY z%DEVEN)`-BO_oC{)6$=1vn+<>IEIvP7?Oh-a-82k1* z_$)QLzO6epJzt-l@*jt>j*ul{f)wel|jI$%`5bI!^9bue$SH`KQjXTQM zx7e}M@Nq|9k9h8mo{c_E&D5H6Cze*`XKD+0*7~~<1~}u}vS|~QU-ab^Hc{boHVrE+ zMBqRh^M$5dmWB_9i3%qO`Jux$GFi4r^M3W&$|*}%ZoE}wIr=3(exH8`p*`P&F3IbY ze9rn)X(0l)QC_fe##*kJUO$C+4DE64wSEyJINr9*J|5TcoF{N{&bQ$4>~l#IYug^) z?Cy%T>rhU5C))+$khP`K@(tN2z46=^a@L=`*V5ER?c=>M}NhSVc~U@&sl#eEkxip$_rLb+3V;i+8AR_Jl|~%eT(nM zmx=S%uF)1Eon0a91APjwpTr+)N2TQ(u~9nXxx(vbpX=|qes+*!6ZKo4>v!cE2AjOt zY5jg{2fBOeyWgVYo?5@3(DEe>Bk1LQt}Xv9)HkE$C1_?mw=PDUbBZD9%(=$CcG}Q$ z{iTe{^_Y7A#{0DoejCaH-zV$$uOgmZd%CXQ2i!h*sotEguWo+%{x#o}O)uYX_vI8` zzWH3gpd?Ge?YexE=Kbokm9w3e?{|1!D7<|0IqOfQg$Ue6mlZ2#tmTU7^-~C1(4N#b zIM4F^PT!B`Y{l|TsEQ$v@I{D=#R@_nw-N7xM}NM;b{S+o3fFv|%O7cf5}uCfcIwM5 zKg(d*>_0<7CF`J0^dfj}r3kezfv00xgiqG{ZXb82Ik-Q<`g#97{{B}j{$9kbT^re& zyw8`nX>5DHFQ+iJ@j2teN(&J<(joXld^afAMw<7l&sI*^*p_Dwf54AhDRbER`KT5u zfioWQG5^cCM9=xv%UeE%kt@V&)}9iu)6IFC(`;wL~iFNhzK3D0#h5BM+$2A~cXD&vZ zW5;l#qIJAR@ra4z@Eh@6zSn$4B@>DA_31CLtsd$3+|TEVKbEU;15 zvwDjx&mZz#Pl-_^IlUeJa_W$UE`sMZhk(~ye(Bg=!UakBVIM!hgV`^o~~T$-}x<1#9q^zX&ZEfXl}fB2$l7F%2M>BXvVTToeIZO zny13#!{3Aly^<;Y5yW#(>3!V&7W%SgGM`zmjZdY82ps1}@Ef9Ok@@^lUsq~A_rM`H zKS?h>*ROV4Ic3kkB6Rt!VsuGPP5GSlr_w?MZlmLA<&;2|)ONAQcqbxHKlv2&$Sv}G z4D>TPR9c9nU7`7bdQ&3Lp_VVKBs@&Fv^`d+?S_}ctD<-r;~lreoWJ+LgB}UqeH`&( zc-LHN))uDfc+T3^gO3utW4+n&L_2Jb6rzchb9M^_z-@3G3)N|T<+>7&1J@kZe+fL- z9m+g0-A&&41n#51xnC&%B=TE7D=kFQu29=iZ|Xx6`&#M3)`=CW%i8?dP{#(xW}POr zB^PR=jU~si(^zs$IgT7p@^(C)qlj}JeF`3Qb$=UW<@J~c?(fg+Iipdfg+kyqIuEQ~ z&R_P!(Yh1ee4Ih5n$DLfB#RdD@H?-HiILH3{j?eG< zXZ*`_?1jeD+GF)^)xM!DRS^1f;X@z@>AM=j&mhc>$9c;u^YtdpEvIId z>a+9B`K5Xzy)Kj#?dDd!_;dlNhz=PKhICyx2&eB6x*F|ZehFGo)CXgChppT^yKuJ{i9=kYip14T%V%y*DLRvM#nFp{2b$%@H6voAs;3C zqb;sC*?;u2Uh>7~{dl_djq%@yH~Men_~T2yyg%W1S~-{Ey3_i52=}>eaUJHIV4Uk0 zO%;v-Ffho&-IJ{P`~5r z9Q7ys(C7N|?i-VN(C7N|>eCWD?{ocmj|!5Pv-(`WD>ujZKZAVA`P%3DUAZ~xzpA(&qvwUyDUUEYt!D= zdc`K`h03>av2})P6zNFMd!*f0;cY))e`lBafRq1!htvn3_#D@9Yk#GM2wX(RLhVF* z+&&QD7{`j`e-R$>S6TcI5zqFAd_~9pkbmOmnLpb;<_o@1`?B?3hH~gw7W>Th-Upwp z54X$}s*mOU0X)i2c>Iri-0?QkzXsn!KF-S9e@Z%{t%?dy2P=tmhXmeVdqoMlpe;`kkcCtqF)Pe=N)P3-SCeEf|p*Z9@`1Z4fcm9-Yw zOz6Nl-?kRBrtC-tu3?J`jU@6vET8P66iZ6S2uw;}1Ro=+p};qBA8mEqhR}_+(O|rV z#PwYvx^P7Q7(Uc7{H>O+fNjirwy~S1^xn-=g74;0FYE5=jl+tDTmd)YIRo-|j-UBU zaNWyu7MUkvb@Er>zWFENI*-2!`RMIA3yySooeah1p<~bcapF5M&|1$EKUylZFK;Dh|x8T`4{@0Mt{Ce$qJMwPCuU9UO zbo2Q4BVR911G|3s52Kt;o>nFFAC3ISaJ>=#Njyg%m&NODSjGF*9-b#Y-TY^e_Hg?z zp$+T#uOd$`e;?A#_nPZW`&tkG4Wya>6I{psPZ2l&EnN5Ve}?p||8H>5{J+F?FaNKQ z-pT(Z?iclcjb}Rfe~tU}|2Fb=kKy0u^#2R;ng1@X^Z5TA`ON=&T=(+-7t+oD2VAe` ze}Fvn|8L~&9>f2*j(-s8=D&~Y;ETx7%uCCNk#q6tH+Kz zS3P>~)pXUPkNFVXhpSIwfbjZ|Zuwm<~Z29i>!V8WA_chqZK7YdnL)Fy~KNaFHzTaI`Z$HOcDX(-S^i z`Kyqx>O%Z@I=rIg;#CW8tES^~5BT`Y!~Oa_K2A{@u6o=3KD<2>9&h>k*>L_IfB!WP z_;BHVAHJ~V!{@nRsQSXHkH0L0)A#$hh1L#hpFMwT$oI35ohxVKmp0jq^^N$G6A8^gOJSk^CTY1?(SNDf{4*GT^bf|>%J)vF0q5b2bynUg+ z`$GTsTY9)}bV~At`v+Y&o?Er{9$;_xKE3+LP|qX3eC2^#E03u@vgZ4{%lG%j|LpsB z<9`kG9SQB&ANsY=4ae!~0qZZj_fOxx@yDSbyWH>`y7509yYcn^@Sc;^@leiac;4DS z>f4jh;i^?nrz5-l_#XX;AK$CPxY_+{uJ_~g4BY*A3|Hx}exF1xnzT207G|=(tP|h`OV7^_w>bvatp=z?2*z^0- z^ky;rS~=y|#E<8Tjd_Zx>Sc!cX{I?$-dC5nj{TJq!Ka_Fqf4Fq?z-=`8dy zAGdbcv)MeBH&3`;8F6~%x@|EW4(*Ne@m}oXwD@|xJWS6nkYQ2myck|>Yhbb}LVD>a z1Em(jq*E1CNNz9EH_YzYv-TXHji0mo@x9&1GwSoDIyGv2Ibs(_?V`P# z#TI|oGh&j&zEJAO;_?Z*oH?}+E-SP1jpcAXeA2Eevn#cx-M!1MDt9#IX6){r4ZEr> zhO5enx!Q_d&(v0?{n%9463SS^E&M$6&_fSo#>`}$(dP8R)a>z4!U$sFa_?-dSv!1u zrM5VS5+L2MgU&dBk`6rx{AZ|!_oEC1mRE0kFVB!aW{u- zR^-r+LREN_#oQFqdHww8daqp{L_RBaFTdS5wNRU$Tfp5=f*YZzA+94GN}se6QPaL~ zZ6_?wl8GG+&%My{`r3zD6dlKJIWqD6*83)IxjJNwn>KROEiYOl9DCEX4kNaOaobtH z-A9<>KpWoMn_ifknqHcv7>H7bxpTpsb2}IUCOh&D z8@e^79x3TE#o#fsmvQYTkf#StV5dVj2mN|@4LCYoC15h#;VOo(2+h_mV>Ih_y@qm~ zu43ftc0HURVyCMZCA(dB>BxF)Tck@x8sDv%9mlG}xa67_Ie54WS=Pq4ONRC6))^1F zQ8Ul|POQ`WUbpecbH5Xt^}g3_MDyJ5IO?6|>e{^yJke?XuHDPUG2Ku#2Pbty$+Hh1 zrr~;co9OUitRGxc-hnlR5=xK@xq9_Y6EnaCgAC=6V(<#aZlD}e3|_&QB%MjozHQ0B zJL@^~wr#;(`FOJ}9=w9P^6_R#F?a=MCrF7q{jQ74POURLF}9+gKPh!)XWCZK_9vxI zXbw}0=2p=5C#6nkSht+EKPh!WAGqbT-Qjh*Bc~wmZt6PHx5m0xU1KM|)wGE<(fi`R z=hBK{kUz^mon+KaD7*oV7)g}UQEV_tw7(H9-VQ@Z26Z#gK`*kd2? z^9@$C(U`BBeS)YVYIJ3WwJ*WNGS{wpI3M3NX%}Y9q9mSdl}3%x#ktw}nvs8G`RFk- z$XLG4E(bBsZf~yR@p<>mLaosV9UEPkyK`>AVyUF`LtRTqXN${z_*3%sE^ofwlT%C6 zMy%0E_vP9^$nnXk`cj=Mp;2}@mAsruR#Bo=!YezT8L*P2E!;XRWRDLMM@d}cN~6Z; z^W!yc_!cwS9fnDzUmyl2$AMdGEAuq0oVeN9qx$x*-FwGt^WxW!9 zQu3x()HSNC-~Ww2IX1a;cmnJ5;bcjkcs|zSwY}I`lM|Cm^()ic)$zw?b3ML8E|uL* zInhKkdAR3}6D)$+qkA!fhf#bX*i0ZNaLxAxciqU>u)VW1zAewKSb^W91Q@SbQAKij_# znZ)-d@BjJdE4R7#Qj_$v{Ck2){K!|`dy+}~s_(lBlX!UV5pgP|?6n_fuAaWNr@p#4 zw=zEya@wmgonP}#6}I+9TdE4$zNf43_Uq|;nQET%EU_C*LOADj=*_3#3C zrZMEYdZZxj5wj#`%Q;rt^hK#<@;2PPvG2md`l(g>lZY3HVFl=~yp; z`9VhDSU!zV;4Xg%KWtBk+sm7m@IIUik^Z<4cOl}B4{;YFerbri5b-C3xC;@#EW}-i zxYc(~xbNaqR?VxjE{0^e>@)S8k5_-FTN!zbiLK{f@s% zsNa>FqkhNFCDiZA%~8LbKPA-f%C&iPQ45pd;de#muCO>@GVo4V4Bid+Uw91=7W=h5 z2Nns7!DqtaHaUt|dJ%2bOgB?{x0t{NX{$=dn9Lqt^+P->OCurA>>TyUqJ`yUlSTg|B7kBv->>n z_idMb$be(9_WT};bRGj zp8Gkl&+TVQurbn}AADxmt8;#x^FtofIX~t^4|`K#G3X;K1`*&4J1Z^55`7ET?xH#u zXUk>f4Ja0C&kr8ZIls>N`3<%nIuB<*kVEd>(QA!io%a0N^Y@Uq#;CXNx4e;K?#afd z1iC{ma{BNb^w*xh9QyABIaBBS;0>Mgg9vcI6!S&*T#~~;J7MvKXY>>D?i&_pH|4`v{A{E5hRb{C5u4Fxgy1{G@aK&0+BbXsPe^ z_dajWA$K_&{1W62+4h4!bI@Ps{Gd}wuE?2yzTu~D_~~2Gn241Ye&9BtbI>_I=$8Zg zb+**~Y)R+*;31v!6Nxs3MLOpP{c>QD^sk^(3HzX(pnsKZKX^m7{k?S!kQcS*&xf_z z^Mg($IqmsDSYVZtdvNJO#2wEe?!pdO=GK3tyAbJaE+g(j#N9fExC;^Q_CKY1hZMBw z@lL~zp8JwB*F96!o?m-@VKFcg@}lf5L5C9doYKF7t~u5sVR3gX)}9|c)Im<}Cim*U z`arK9a&M_~EyrBfT2ta$V>WVnpI`6u_rQQLz0WUuQp1W$3xEW-2|EMXlY)Lm&jGb3 z)j2=L5OSvUubaaHC*S3e1EqfjolDR;2#W_Fi?!$XSnTv?xO8EUvo7uVL8Kn?zV`f} zPYGD-*03CFo#WpU>UZUu+^Idk_WV6CKzn{*fX$Uk3lX?Y?0L7v+|PkMP97`)dn9Lq ze~h2B=il5rr2HNLXgS310~~;#fREoP<$s1f2v5iF1^n1u`S0XMa-qXG#N8egSzL&? z&iO$Mo%8#BL$Xh z51x)|%!m(Va|Jq-p!3)XSgbuictd;sb>$BCy{{bS>~2n!HP>>~uXFx#uugk^&{cc> zT;I>po*%qod$dXm5jgGn6B=mGuRXuBo8)>oqXbA@|*rZMC`hSbAHg(*7gClxze5=W2im9_WbLdwK!cu4xPh}UTX~N z2E?}iNjOX6{=)4+e}s9?_j4p?>bw2mi6ZB$n)_kiaBtS*Y)xlNpic>M_D(ok5*C9u zfIDuE;L?SNyR#I;U5L0FYs6iMxP4C``;Mvh{Gd$_EZWg>SPnTfCNrhoY0`C zU4XMm5*7=K{Y-MdMRBXB2LA|)-88bFB0NO7_?UDQl8Y-X&pyIpVX@?5gVIfh!eWpRItO=_ zgi9A9?#}NKcOl|VjzQdo(oujCaKhq*21Vu(=_a`t{3E&8O(Xj$!b6gag~cPz9=7G# zM_4Q@mRxL5y6Lbe7GEnJg>)2^mghTRv9MTJylD)!0))k&gme^LzbWW+HYM11%DxzU zmt&8vcRfI-68O*AXV^Q>1Nwaj$;BSK_1+!mAh|f9K@pio`eNC%VfM7SB0NNW@paNs zNJmj=c|H;r3yYg|G#5)A|Jd z(fZ`3k^L0mAz`uJ3)g$$m^qaee&9B-772?%KVh+BBl{5+gA&rAONTBUx^(CUiVss* z6pL?IPe*Y9IzqlaAD(gpLdP+52%i7>#{0WNd^E)OggA9NOy~dkGXLHX-xuO6 ze**qecskZ|0RBNn;8-4YEpSgndtLn@J{IEcJOxQEMEjg=C*m&L05)5F+5h-+_2*ds zUAy|NtIbib>wmxN#dx@KbJXwXT|)h?+#L1mi~vku0{xxbZ|_|X$bU@>+dNjfvBRYc ziQNG^g>9gPu+4wpH3zot=>KmWFl^J=lE*f^pW!jg$;`mABJw|<(f52nzZ}@7@A-gE zCCHUdt~cx*(C_&Oi-pBQl@^Eq2TV0DEQYFv`k8}{CKaduIoSD~Q_@UlOQ2JZwWw4b zi?Fyq`b_FOLCYcPJE_Z@fRFW?oD&`No0oUdZ#p>*kGK$fc>Na#h+*<;337?#V$e4S z7D+A!ol4-pogf!W{|ep!R!jd1I`okHbheZaYo&h$ol0^=_G+{z6}Dj@gl+5YX@zaz zlN@rSu&pFuL$O7%P5MlaZ8}>59i-1pXi#JxNuRk*Y{sO|ls=P7D{Y>DWlq1ELmnBU z9=6|logDQ#y<@-YH9cvL`ggP(mZSgDXO_VC;J=-q&y-vY-oTz;avX!TPJ_q(| z58ZtaEi48P35$uu!eXo`8`bCPy(Q32Sj<_JxFUNQD z&iO&75_D2K;hbN#{ooCqE$M7YXG=ZL)|}iwVER{Ko3IV?rLaxdw&So(`b>{)+Czg5 z+CwKaD58rZ-K5V1|K!ji=xj-6OU||g?Bc=>duCy=uy`|Tk+4`;3<{)Nk@Z|>OFCQ9 zf8SyHR9g6f+r+*=SPc3}E_Q5WKSi-v`d3h{gPg4YB&pBN-3{7=?-a!-l0EBJAwiw%GqlL*cVCUvKTk=>aeJ1Fzi9Mv| zKIoT2u9JNx=p_5hMq_@d-neN^evm#>`b_CFfen=we&9B-7D=B8`sG-Qbk47H{`L0w zl8ZNoMUsp2VUgrw&`EM}N4Z#MOW+NiEy=cDw*5QKwqMvLY{Onx*d}b-aoDD_C68^| zLxT>R(C29n4f^HK=V=cOI%yBxaStsl78VaxS|9?PusESX5nDjgO=nBspB!tE&X#nx zq_ZWDwN8F5K`xP8oDYj67lTeE@SnqYvv<9yg-RZNS7bfc|1EWYzhAcfYqoim`}E!t z=5`LbPwy?2hk?R2&{pp)c?Pp}x6<Z!OZj}%hN+Tm_!d%1Sb-kGUKNK(ZA}wC9r)59e~cwb#AV2 z;$d!t@4Y%Xdcd$vXG5OW?B-bQn9qK2umMEFP+~Km<5p zaY6%OF}7b1fhP_+z8H+}Czu>OptkbDV(^-5u0RAhVR1qOVX?5-Pl}EI7U3bix76JR zOZr#oU!{Kq4h^vWRcA{WKbt$pT@S&J!e0QtC&b4>oZnPr z`rZ)V7vlRv9Qp{CegNSF{H5@8+}lyF@*pE{ET8KM+~w4{0Glj67UGV_aodGRmwhIP z0Xk~#gAQfQ{T$e^cNO`{=#Aq0WRo$oSdG6CxykJnVrj4T8O}LtqQ(~ zUY^gmeNPU$JIpKr3xvfOyBzcv7I%M#RQgx&ko2$8zv@3pcHDoG2-}2hkkf>1!nPfU zZL-hw*rxZEK!;82VV#~d#~#YB$f zVVk$-=DvyUT=;jua}LXk21R&4yd!=o!Y^@NzK{5hV7D>aXx5rjS1C3mN{9>aes1CU zFf=s&5FF;zV29q0t9bwQoM^T)kRzGF)WnW(Msuay8`j3LJ8LWRwdsYq5Ia z=N7`N`1b5B1Cu3 zt*k7qgvj0#&BoNs(!%Ou9WTzJy%n~XUm+N7;Rk@!@b{B1JMIooR%U7|vmLHSo6`$Z zv&Tcq2x3;%Y^_;4e0+tSa6(s#JZ1p8kB>K27Z+`$8ZIg zgxCHB-CtIZ9e1vJ^xmuKsz)F5A-E4$pTq#+^&#EzyIjb3Bs_mrNI!D3FYj=OKQ5$O zcxAX>^#xR)Veucj8`Wbi-@YfiV5n;4ToKw~^*%M!b3@2y6!95jJu4>N5Ww5y2dW9wTtUBjASD|db~E% z1Veg3+z;+7VsKRpUlHQV6YipVXUm5RnfUarZWOAuK)l%>dg57l$J6|vX2Ua~yw~6F z%RL?9FaDg*|DqrG@RmRK<=;N)!^Q(XKPCxXb@c%sl6B##FTUT0x1a0Vaa(wP^&kEH z=?NdM{8h+Tbs>H{9bVCL@v4QlRnzgg2YmeH;eP!dAAf-hhN`#S@8h>;!s9J}KO4^9 z*DKq?v3I$IYBt=n%!2Qz^0O^))p1ty$?sGTqOc3^dr|dVmU`iR)q||< zb>FL=75FWwKeXqp@SL^No_|Dm{(x)NcDdm>bmMM(A0|C;OlI6XPg;~LkUq3X4N=jZRy zn>`;L4e=xH_VMbGFrG(4{v-c|1AV%B20C6H%DKi3%(tso zeU}|SR81BWdwzeq-mC6)3{$--Jbz`V*A|Z}13w-0?LsO)AT;4~xnBcrMtDtU_bl{x z+kY+H!fX!Sr?b$$b&kIJ7s;$9u7l)8gy(@-RKSK!!!J z^I~|lt%1p^2VwiNQf(q%ak!%33dCwYadE$oIJ$u%k($J;i__Cu4eKurP^uV<2Fh70e?RkGm~}lOT2C)0Gc|LJ!u<6 z+TnwUU{G3o1?ZV`nb+4cHA~>zVLW_Up-< z6!PkY@zb8HJxIB&Gp;v7Haab$nKhhmhB)Rk_GJiBiPl6<0%Nk3?u7V9o=KgB7Vf!y zc8nl8Z6DoP`^(OmZ=3!F^H}xl~vT z+LRy{3X4J40mov!eTp%ZTnr+>NiI%kP*g`E9R>I&hg|M-2_>vWJ3&VwECvq=i;2Vu z4oOE*Twg6L2LA|)-88bFBI~)n$`Zb&AuRUnBe^(PkBZDAu3f@nVX0@x|Lc|?!BJM)O-I)yHE=1hP35dH8 zad)3n55m*&>)+fy!@2DPMI7qb$VnH2YUaHk%$2>Cs0`KGy z17!Zy-TX^f3?2ej3yarqn0PEK78c9=3v*%P=_EUt1WQr?O+V35q!gl+mNE^Y4y<+CHgHg8AS8Wh=zk!}u#ax4QhLKq4>854P}bEW@4b%g@whN(U(gu2LDJdj-j}ao=;dT zEY@ogm_C&je&8e*Cp0J`(~)kHi#-d)zeQ*$Q(XOtyEEsJxmxe95d&*r|Prnr=?gl*%%u5MqN2e!);cW7vQa;m;mUz~3=0>6wdPerluS(ZX)@gq9zBzV$e-k?3qVcoUBJh<`LI0=_tTLIo2ZSD7xz? zgvG+*p-KxxfD;xcG!Pa;M6s`ZWnc~V6 zSEjg>Ero464cnl{8!}azYERy*bNSFhQWQq$q$rM+nxL^Ze zaXE8ASS&2gvlhwxOXgpai-8r`gFDPDK`s#%3yX!t;DN{$)ltY47sQi}!gJ6j^rgaL zkWe}by`r`WEWTkqJBkZX_ zU5NO4aR9cLA>?VH07ugr&kz<5ypsTQrT-HCn1E0DxW8>osTCVu5 z{wXq7n0JJ72~Eu(epB3w(G)hxi9A0-lPD^2sm49R!_Y&h^Dy0VvHHET38G^2#XUM6q!e)n@n-RKRMQ-Qq?^Jj>T83Cl^y*-3qyQ z0`YwfieyGHnG90gK&S!lerlH#-NJwt^PGXqmQx4mq&K*}s$^_qlR& z)bIGWg!)~%rUMud{j0DIJS%Kl_baQyHeuU9oh@NbkC^`0Oj~!^2WEFohR@6HS`HWG zd|XymR32SrMFl!&7oX5TyLbp4hE6%YalS29Uz2PH^mI#DEG!loV4j%VIUpKUo!onD)1Du6ker#&pook>y1CPo z9H%+5q5_|laGE76D$w;1d_O))r7sGAjx7)qZljo(0}GtIRKi@49ENerL4RQ}=u`s# z35!8jVKImR7d{~9zBZF%PLA=Mq2D~2qh4Wg33QiSygjV!OeZm*XJNAX!rYYpRr*)y zU-5=*XUq3Q2V+<_Ao^Efo3IVMD{K?C?JR7QMQi+-e`!>uQQfE}8P9EtcZG6jQKV5V zM~ku(G^(;_^^&eE4M2xYV4+U8KtExz|K>eUyZJ5A^Wf>oSNwY>gbp+NeUf11nwDWe zHL9{`1&>IhDy@UG4m(Thpl`G$-#d|<8RUT=YZkTWl$;6rNzRm<2{tfSWDfDoDZO0) z%0bQ)7K07}hZz>(Bjy(tgMPwdVX*-*!Xk4>SiJTfKw+`4cr$B}-t@}17D@lw*;0*I zEUPc@ko2$8ze@kQHenm&D`A_kZD(PdELvsJ3TTHj>yJu{v5jjsb7=JRUMlEY zf)$T;@t|uC{?jhL`z~G7V@Zh;7JI^9ZWP~>ESbQ2bXe}u(u8re?~9?~~j!y7`< zs7mV~t;5dJI>?Gj7Ol`X3{_hAfs>q>(4dHnAUSiJ{NtnP&Ia_&DOt1vgS6*&P%JE7 zTaSdrm=^kvEI%(c_*;aBWYH>%))C3Yec2aC{|dm8{xyZ#MX^{`Um&0KuhPFt|GMM! zufjHA8}|CbHeuV&!Zye&Bc`($3;eySZWohwu^cXTPfjgOH$r4|a%yqDVX^Vasrphq zx-q((N?uNq-9Lg1p9@48!{!C2Te70^=&JWpK?j{~B{V3q1Jmi2PPZ_7+FTJH5*ACN zDvc_pP^E<*xJ|4@(x`%d(x^H%vY(<@tZ%e}a?+?u>maSe&eA%_qE!~HI=PpeS!sFE zXcKbw6R5qEoayNpev8VPvSqe|Ctwu)`i-XJH_YusESXk$I%EFr9^A_O!VoJjAmwS$%0p-YduNvF&H4K3(rP1Yc4&8xr0!ix_jbL38(ABGjgH~)1_q7*+|BQGgX%ZO@pZ_*y?T^l z!QJ!6YxPqZ7TfdE`fKY;chxhu$4+|-^D|i4&qW%xWT~?D*A|vf*6OQ^bKu*Jr=_Sh z(mv}doo868DWfw>3#*IPfey2O>zF9jowE!XW^2t_xE`K96|QzK)TZYQT*e#CT64b9 z1S!46$>{9-iTS1>PNjKjdCs1@v$n8mkv+8epRXIt?GMqZ=G@%|XURQQ5z44EmR9U~ z&+^>L%v?Q*&evxaR%hohq+sY&e|Cqb_cm+O3v*M`OS9IOv;3V#^VGsxW5xkz3sVc| zm9-oQIcr@Sov$yiqJ!x_(i#p~_cf;%rW&h@i?tQ2WBf$ZZuq%Lu7pc9(Kx6Qk$luO U?ua#hW$whv9Ei3=hWYXT4@bvznE(I) literal 0 HcmV?d00001 diff --git a/renv.lock b/renv.lock index 442e69c..074b3f4 100644 --- a/renv.lock +++ b/renv.lock @@ -8917,54 +8917,6 @@ "Author": "Simon Garnier [aut, cre], Noam Ross [ctb, cph], Bob Rudis [ctb, cph], Marco Sciaini [ctb, cph], Antônio Pedro Camargo [ctb, cph], Cédric Scherer [ctb, cph]", "Repository": "CRAN" }, - "visdat": { - "Package": "visdat", - "Version": "0.6.0", - "Source": "Repository", - "Title": "Preliminary Visualisation of Data", - "Authors@R": "c( person(\"Nicholas\", \"Tierney\", role = c(\"aut\", \"cre\"), email = \"nicholas.tierney@gmail.com\", comment = c(ORCID = \"https://orcid.org/0000-0003-1460-8722\")), person(\"Sean\", \"Hughes\", role = \"rev\", comment =c(ORCID = \"https://orcid.org/0000-0002-9409-9405\", \"Sean Hughes reviewed the package for rOpenSci, see https://github.com/ropensci/onboarding/issues/87\")), person(\"Mara\", \"Averick\", role = \"rev\", comment = \"Mara Averick reviewed the package for rOpenSci, see https://github.com/ropensci/onboarding/issues/87\"), person(\"Stuart\", \"Lee\", role = c(\"ctb\")), person(\"Earo\", \"Wang\", role = c(\"ctb\")), person(\"Nic\", \"Crane\", role = c(\"ctb\")), person(\"Christophe\", \"Regouby\", role=c(\"ctb\")) )", - "Description": "Create preliminary exploratory data visualisations of an entire dataset to identify problems or unexpected features using 'ggplot2'.", - "Depends": [ - "R (>= 3.2.2)" - ], - "License": "MIT + file LICENSE", - "LazyData": "true", - "RoxygenNote": "7.2.3", - "Imports": [ - "ggplot2", - "tidyr", - "dplyr", - "purrr", - "readr", - "magrittr", - "stats", - "tibble", - "glue", - "forcats", - "cli", - "scales" - ], - "URL": "https://docs.ropensci.org/visdat/, https://github.com/ropensci/visdat", - "BugReports": "https://github.com/ropensci/visdat/issues", - "Suggests": [ - "testthat (>= 3.0.0)", - "plotly (>= 4.5.6)", - "knitr", - "rmarkdown", - "vdiffr", - "spelling", - "covr", - "stringr" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "Language": "en-US", - "Config/testthat/edition": "3", - "NeedsCompilation": "no", - "Author": "Nicholas Tierney [aut, cre] (), Sean Hughes [rev] (, Sean Hughes reviewed the package for rOpenSci, see https://github.com/ropensci/onboarding/issues/87), Mara Averick [rev] (Mara Averick reviewed the package for rOpenSci, see https://github.com/ropensci/onboarding/issues/87), Stuart Lee [ctb], Earo Wang [ctb], Nic Crane [ctb], Christophe Regouby [ctb]", - "Maintainer": "Nicholas Tierney ", - "Repository": "CRAN" - }, "vroom": { "Package": "vroom", "Version": "1.6.5",