Initial commit

.gitignore

@@ -0,0 +1,4 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata

R/centileFunctions.R

@@ -0,0 +1,17 @@
+zscoreFromLms <- function(y, lms) {
+  req(y, lms)
+
+  if (abs(lms$l) < 0.00001) {
+    return(log(y / lms$m) / lms$s)
+  } else {
+    return(((y / lms$m) ^ lms$l - 1) / (lms$l * lms$s))
+  }
+}
+
+yFromLms <- function(zscore, lms) {
+  if (abs(lms$l) < 0.00001) {
+    return(exp(zscore * lms$s) * lms$m)
+  } else {
+    return((zscore * lms$l * lms$s + 1) ^ (1 / lms$l) * lms$m)
+  }
+}

R/targetHeightFunctions.R

@@ -0,0 +1,43 @@
+data(parentValues)
+
+#' Calculate target height
+#'
+#' @param sex One of 'male' and 'female'.
+#' @param motherHeight Height of the mother in cm.
+#' @param fatherHeight Height of the father in cm.
+#' @param method The method to be used to calculate the target height.
+#'   Possible values are 'Tanner', 'Molinari' and 'Hermanussen'. (defaults to 'Tanner')
+#' @param reference The reference to be used to calculate SDS values. (defaults to 'Kromeyer-Hauschild')
+#' @return The target height in cm.
+#' @examples
+#' targetHeight('female', 175, 180, 'Tanner')
+targetHeight <- function(sex, motherHeight, fatherHeight, method = 'Tanner', reference = 'Kromeyer-Hauschild') {
+  if (missing(sex))          stop("required argument 'sex' is missing")
+  if (missing(motherHeight)) stop("required argument 'motherHeight' is missing")
+  if (missing(fatherHeight)) stop("required argument 'fatherHeight' is missing")
+  if (missing(method))       stop("required argument 'method' is missing")
+  if (missing(reference))    stop("required argument 'reference' is missing")
+
+  if (!sex %in% c('male', 'female'))
+    stop("'sex' must be one of 'male' or 'female'")
+  if (!method %in% c('Tanner', 'Molinari', 'Hermanussen'))
+    stop("'method' must be one of 'Tanner', 'Molinari' or 'Hermanussen'")
+
+  relevantValues <- filter(parentValues, reference == !!reference & measurement == 'height')
+
+  if (method == 'Tanner') {
+    targetHeight = (motherHeight + fatherHeight) / 2 + ifelse(sex == 'male', 6.5, -6.5)
+  } else if (method == 'Molinari') {
+    targetHeight = (motherHeight + fatherHeight) / 2 + ifelse(sex == 'male', 10.2, -2.6)
+  } else {
+    fatherHeightSds <- zscoreFromLms(fatherHeight, filter(relevantValues, sex == 'male'))
+    motherHeightSds <- zscoreFromLms(motherHeight, filter(relevantValues, sex == 'female'))
+    sds <- (fatherHeightSds + motherHeightSds) / 2 * 0.72
+    return(list(height = yFromLms(sds, filter(relevantValues, sex == !!sex)), sds = sds))
+  }
+
+  return(list(
+    height = targetHeight,
+    sds    = zscoreFromLms(targetHeight, filter(relevantValues, sex == !!sex))
+  ))
+}

hgh-treatment-evaluation.Rproj

@@ -0,0 +1,13 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX

server.R

@@ -0,0 +1,39 @@
+library(dplyr)
+library(childsds)
+
+shinyServer(function(input, output) {
+  heightCentile <- reactive({
+    req(input$sex, input$age, input$height)
+    sds  <- sds(input$height, input$age, input$sex, 'height', kro.ref)
+
+    if (sds == Inf | sds == -Inf) sds  <- NA
+
+    sds
+  })
+
+  targetHeights <- reactive({
+    req(input$sex, input$motherHeight, input$fatherHeight, input$reference)
+    do.call(
+      rbind,
+      list(
+        Tanner      = data.frame(targetHeight(input$sex, input$motherHeight, input$fatherHeight, 'Tanner', input$reference)),
+        Molinari    = data.frame(targetHeight(input$sex, input$motherHeight, input$fatherHeight, 'Molinari', input$reference)),
+        Hermanussen = data.frame(targetHeight(input$sex, input$motherHeight, input$fatherHeight, 'Hermanussen', input$reference))
+      )
+    )
+  })
+
+  output$heightCentile <- renderUI({
+    tags$b(sprintf('%.2f SDS (p%.1f)', heightCentile(), pnorm(heightCentile()) * 100))
+  })
+
+  output$targetHeightTable <- renderTable(targetHeights(), rownames = TRUE)
+
+  output$hghTreatmentEvaluation <- renderUI({
+    req(heightCentile(), targetHeights())
+    difference <- heightCentile() - targetHeights()['Hermanussen',]$sds[1]
+    tagList(
+      'Difference to target height SDS (Hermanussen et al.) is: ', sprintf('%.2f', difference)
+    )
+  })
+})

ui.R

@@ -0,0 +1,38 @@
+library(shiny)
+
+shinyUI(fluidPage(
+  title = 'CrescNet hGH Treatment Evaluation App',
+  titlePanel(title = div(img(src = 'logo.svg', height = '50'), span('hGH Treatment Evaluation App', style = 'vertical-align:bottom'))),
+  'Please insert the most recent patient data as well as parental height values on the left site. The evaluation will be displayed on the right site.',
+  br(),
+  'SDS values are calculated with the R package ', a('childsds', href = 'https://cran.r-project.org/package=childsds'), '.',
+
+  tags$h3('Disclaimer'),
+  'This tool is not approved as a medicinal product for clinical use, and should be used for research purposes only.',
+
+  hr(),
+
+  sidebarLayout(
+    sidebarPanel(
+      radioButtons('sex', 'Sex', choices = c('female', 'male'), inline = TRUE),
+      sliderInput('age', 'Age (years)', min = 0, max = 20, value = 10, step = .25),
+      numericInput('height', 'Height (cm)', NULL, min = 0, max = 250),
+      numericInput('motherHeight', 'Mother height (cm)', NULL, min = 0, max = 250),
+      numericInput('fatherHeight', 'Father height (cm)', NULL, min = 0, max = 250),
+      selectInput('reference', 'Reference', c('Kromeyer-Hauschild'))
+    ),
+
+    mainPanel(
+      wellPanel(tags$h4('Height SDS:', uiOutput('heightCentile', inline = TRUE))),
+      wellPanel(tags$h4('Target heights:'), tableOutput('targetHeightTable')),
+      wellPanel(tags$h4('hGH treatment evaluation:'), uiOutput('hghTreatmentEvaluation'))
+    )
+  ),
+
+  tags$footer(
+    hr(),
+    tags$small('Source code of this Shiny app is available at: ',
+               a('GitHub', href = 'https://github.com/CrescNet/hgh-treatment-evaluation')
+    ), align = 'center'
+  )
+))