NZ GRS waiting list shiny app https://shiny.petras.space/GRS
rstats
statistics
rshiny
new-zealand
grs
transgender

app.R 9.9KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262
  1. library(shiny)
  2. library(ggplot2)
  3. library(scales)
  4. library(tidyverse)
  5. library(shinycssloaders)
  6. # UI ----
  7. ui <- navbarPage("Gender Reassignment Surgery", collapsible = TRUE,
  8. selected = "About",
  9. # Vaginoplasty UI ----
  10. tabPanel("Vaginoplasty — \"MtF\"",
  11. sidebarPanel(width=3,
  12. checkboxInput("vagprojc", label="Project waiting list out to:",
  13. value=FALSE),
  14. sliderInput("vagprojyears", label=NULL, min=2030, max=2080,
  15. step=1, value=2030, sep=""),
  16. numericInput("vagin", "Additions to list per year", min=0,
  17. max=NA, step=0.1, value=0),
  18. numericInput("vagout", "Funded vaginoplasties per year",
  19. min=0.1, max=NA, step=0.1, value=1.5),
  20. h4("Options"),
  21. checkboxInput("vagwly", "Show waiting list length in years"),
  22. checkboxInput("vagminc", "Set graph minimum", value=TRUE),
  23. conditionalPanel("input.vagminc",
  24. numericInput("vagmin", label=NULL, value=0)),
  25. checkboxInput("vagmaxc", "Set graph maximum", value=FALSE),
  26. conditionalPanel("input.vagmaxc",
  27. numericInput("vagmax", label=NULL, value=NA))
  28. ),
  29. mainPanel(
  30. tabsetPanel(
  31. tabPanel("Graph",
  32. h3("New Zealand vaginoplasty waiting list"),
  33. plotOutput("vagPlot") %>% withSpinner(type=5)
  34. ),
  35. tabPanel("Table",
  36. h3("Table of projected waiting list values"),
  37. tableOutput("vagpTable") %>% withSpinner(type=1)
  38. )
  39. )
  40. )
  41. ),
  42. # Phalloplasty UI ----
  43. tabPanel("Phalloplasty — \"FtM\"",
  44. sidebarPanel(width=3,
  45. checkboxInput("phalprojc", label="Project waiting list out to:",
  46. value=FALSE),
  47. sliderInput("phalprojyears", label=NULL, min=2030, max=2080,
  48. step=1, value=2030, sep=""),
  49. numericInput("phalin", "Additions to list per year", min=0,
  50. max=NA, step=0.1, value=0),
  51. numericInput("phalout", "Funded phalloplasties per year",
  52. min=0.1, max=NA, step=0.1, value=0.5),
  53. h4("Options"),
  54. checkboxInput("phalwly", "Show waiting list length in years"),
  55. checkboxInput("phalminc", "Set graph minimum", value=TRUE),
  56. conditionalPanel("input.phalminc",
  57. numericInput("phalmin", label=NULL, value=0)),
  58. checkboxInput("phalmaxc", "Set graph maximum", value=FALSE),
  59. conditionalPanel("input.phalmaxc",
  60. numericInput("phalmax", label=NULL, value=NA))
  61. ),
  62. mainPanel(
  63. tabsetPanel(
  64. tabPanel("Graph",
  65. h3("New Zealand phalloplasty waiting list"),
  66. plotOutput("phalPlot") %>% withSpinner(type=5)
  67. ),
  68. tabPanel("Table",
  69. h3("Table of projected waiting list values"),
  70. tableOutput("phalpTable") %>% withSpinner(type=1)
  71. )
  72. )
  73. )
  74. ),
  75. # About Page ----
  76. tabPanel("About",
  77. p("Since a review in 2003 the New Zealand Ministry of Health",
  78. "has nominally funded \"MtF\" GRS (i.e. trans women's vaginoplasty) at",
  79. "a rate of three every two years, and \"FtM\" GRS (trans men's phalloplasty)",
  80. "at one every two years. The retirement of Peter Walker, who was performing",
  81. "vaginoplasty for the MoH, in 2014—coupled with the apparent increase",
  82. "in number of publically out transgender people—has led to astronomical rises to",
  83. "the waiting lists for both types of surgery."),
  84. p("Several people have obatained details about the waiting lists from",
  85. "the Ministry via Official Information Act requests since 2015.",
  86. "The data obtained is summarised at the bottom of this page;",
  87. "if you have newer datapoints or others",
  88. "that have been missed please send them to me on",
  89. a(href="https://twitter.com/OleumPetra", "Twitter"), "or",
  90. a(href="mailto:oleumpetra+blog@gmail.com", "via email"), "."),
  91. p("This app shows that data visually, but it also projects it",
  92. "into the future, allowing the rate of people being added",
  93. "to the list to be changed by the user, along with the",
  94. "level of government funding. The inadequacy of the present",
  95. "funding levels can be easily seen, and the size of the increase",
  96. "that is required estimated."),
  97. p("Note however that, as this crisis has been ongoing for some",
  98. "time, many people interested in surgery will not have taken",
  99. "the time and expense to formally add themselves to the",
  100. "waiting list. Therefore the true size of the problem",
  101. "cannot be easily estimated. In addition the Ministry",
  102. "has contacted a number of people on the list and found that,",
  103. "given the sheer length of time that has elapsed already,",
  104. "some do not wish to continue with surgery or have found",
  105. "some way to self-fund, shortening",
  106. "the list without actually funding a surgery."),
  107. hr(),
  108. h4("Known vaginoplasty waiting list lengths"),
  109. tableOutput("mtfData") %>% withSpinner(type=1, proxy.height = "100px"),
  110. h4("Known phalloplasty waiting list lengths"),
  111. tableOutput("ftmData") %>% withSpinner(type=1, proxy.height = "100px")
  112. )
  113. )
  114. # Server ----
  115. server <- function(input, output) {
  116. # Data logic ----
  117. pData <- reactive({
  118. read.csv("P.csv", header=T, stringsAsFactors = FALSE) %>%
  119. mutate(Date = as.Date(Date))
  120. })
  121. vData <- reactive({
  122. read.csv("V.csv", header=T, stringsAsFactors = FALSE) %>%
  123. mutate(Date = as.Date(Date))
  124. })
  125. output$mtfData <- renderTable({
  126. vData() %>% mutate(Date = format(Date, "%d/%m/%Y"),
  127. `Length (years)` = Length / 1.5) %>%
  128. select("Date", "Length", "Length (years)", "Source")
  129. })
  130. output$ftmData <- renderTable({
  131. pData() %>% mutate(Date = format(Date, "%d/%m/%Y"),
  132. `Length (years)` = Length / 0.5) %>%
  133. select("Date", "Length", "Length (years)", "Source")
  134. })
  135. # Projection logic ----
  136. vagProj <- reactive({
  137. vd <- vData()
  138. ld <- vd$Date[nrow(vd)]
  139. ld.y <- as.numeric(format(ld, "%Y")) # year of last data value
  140. ld.d <- format(ld, "-%m-%d") # date part of last data value
  141. lv <- vd$Length[nrow(vd)] # last length value
  142. yrs <- (ld.y + 1):(input$vagprojyears) # Vector of projection years
  143. ny <- length(yrs) # Number of projection years
  144. pc <- rep(input$vagin - input$vagout, ny)
  145. pv <- cumsum(pc) + lv
  146. pv <- ifelse(pv < 0, 0, pv)
  147. dates <- as.Date(paste0(yrs, ld.d))
  148. data.frame(Date=c(ld, dates), Length = c(lv, pv))
  149. })
  150. phalProj <- reactive({
  151. pd <- pData()
  152. ld <- pd$Date[nrow(pd)]
  153. ld.y <- as.numeric(format(ld, "%Y")) # year of last data value
  154. ld.d <- format(ld, "-%m-%d") # date part of last data value
  155. lv <- pd$Length[nrow(pd)] # last length value
  156. yrs <- (ld.y + 1):(input$phalprojyears) # Vector of projection years
  157. ny <- length(yrs) # Number of projection years
  158. pc <- rep(input$phalin - input$phalout, ny)
  159. pv <- cumsum(pc) + lv
  160. pv <- ifelse(pv < 0, 0, pv)
  161. dates <- as.Date(paste0(yrs, ld.d))
  162. data.frame(Date=c(ld, dates), Length = c(lv, pv))
  163. })
  164. # V plot logic ----
  165. output$vagPlot <- renderPlot({
  166. vd <- vData()
  167. showyearsleft <- input$vagwly
  168. if (showyearsleft) {
  169. vd <- mutate(vd, Length = Length / 1.5)
  170. }
  171. ggplot(vd, aes(Date, Length)) -> v.p
  172. v.p + geom_line(size = 1.5, na.rm = TRUE) -> v.p
  173. if (input$vagprojc) {
  174. vpr <- vagProj()
  175. if (showyearsleft) {
  176. vpr <- mutate(vpr, Length = Length / input$vagout)
  177. }
  178. v.p + geom_line(data=vpr, aes(Date, Length),
  179. size=1.5, linetype = "dashed",
  180. na.rm=TRUE) -> v.p
  181. }
  182. if (showyearsleft) {
  183. v.p + ylab("Waiting list length (years)") -> v.p
  184. } else {
  185. v.p + ylab("Waiting list length (people)") -> v.p
  186. }
  187. v.p + theme_linedraw() -> v.p
  188. glim <- c(
  189. ifelse(input$vagminc, input$vagmin, NA),
  190. ifelse(input$vagmaxc, input$vagmax, NA)
  191. )
  192. v.p + scale_y_continuous(limits=glim) -> v.p
  193. v.p
  194. })
  195. # P plot logic ----
  196. output$phalPlot <- renderPlot({
  197. pd <- pData()
  198. showyearsleft <- input$phalwly
  199. if (showyearsleft) {
  200. pd <- mutate(pd, Length = Length / 0.5)
  201. }
  202. ggplot(pd, aes(Date, Length)) -> p.p
  203. p.p + geom_line(size = 1.5, na.rm=TRUE) -> p.p
  204. if (input$phalprojc) {
  205. ppr <- phalProj()
  206. if (showyearsleft) {
  207. ppr <- mutate(ppr, Length = Length / input$phalout)
  208. }
  209. p.p + geom_line(data=ppr, aes(Date, Length),
  210. size=1.5, linetype = "dashed",
  211. na.rm=TRUE) -> p.p
  212. }
  213. if (showyearsleft) {
  214. p.p + ylab("Waiting list length (years)") -> p.p
  215. } else {
  216. p.p + ylab("Waiting list length (people)") -> p.p
  217. }
  218. p.p + theme_linedraw() -> p.p
  219. glim <- c(
  220. ifelse(input$phalminc, input$phalmin, NA),
  221. ifelse(input$phalmaxc, input$phalmax, NA)
  222. )
  223. p.p + scale_y_continuous(limits=glim) -> p.p
  224. p.p
  225. })
  226. # Projection table logic ----
  227. output$phalpTable <- renderTable({
  228. pp <- phalProj() %>% mutate(Date = format(Date, "%Y"))
  229. names(pp) <- c("Year", "Length")
  230. if (input$phalwly) {
  231. pp <- mutate(pp, Length = Length / input$phalout)
  232. names(pp) <- c("Year", "Length (years)")
  233. }
  234. pp
  235. })
  236. output$vagpTable <- renderTable({
  237. vp <- vagProj() %>% mutate(Date = format(Date, "%Y"))
  238. names(vp) <- c("Year", "Length")
  239. if (input$vagwly) {
  240. vp <- mutate(vp, Length = Length / input$vagout)
  241. names(vp) <- c("Year", "Length (years)")
  242. }
  243. vp
  244. })
  245. }
  246. shinyApp(ui = ui, server = server)