Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- # install.packages("profvis")
- # install.packages("scales")
- # install.packages("reticulate")
- # install.packages("shiny")
- # install.packages("tidyverse")
- # devtools::install_github("rstudio/rsconnect", ref='737cd48')
- library(foreign)
- library(shiny)
- library(ggplot2)
- library(reticulate)
- library(scales)
- library(tidyverse)
- virtualenv_create(envname = "python_environment", python= "python3")
- #virtualenv_install("python_environment", packages = c('keras', 'pandas','numpy','scipy','scikit-learn', 'tensorflow'))
- reticulate::use_virtualenv("python_environment", required = TRUE)
- # Define UI for the health predictor tool
- ui <- fluidPage(
- titlePanel("Health Outcome Predictor Tool"),
- # Sidebar layout with a input and output definitions
- sidebarLayout(
- # Inputs
- sidebarPanel(
- # Select race
- h3("Health Outcome Selection", align = "center"),
- #have to figure out how to structure the =x to make it so that it will be able to call the correct neural net
- selectInput(inputId = "health_outcome",
- label = "Select the health outcome of interest:",
- choices = c("Anxiety",
- "Overweight"),
- selected = "Overweight"),
- h3("Demographics and ACE Data", align = "center"),
- # Select race
- selectInput(inputId = "race",
- label = "Select your race:",
- choices = c("White"=1,
- "Black"=2,
- "Asian"=3,
- "Native Hawaiian or other Pacific Islander"=4,
- "American Indian or Alaskan Native"=5,
- "Other"=6),
- selected = "White"),
- # Select gender
- selectInput(inputId = "gender",
- label = "Select your gender:",
- choices = c("Male" = 0,
- "Female" = 1),
- selected = 0),
- #Select if vetran or not
- checkboxInput(inputId = "vetran",
- label = "Check if you ever served on active duty in the United States Armed Forces"),
- # Mark all of the ACEs you have experiences
- checkboxGroupInput(inputId = "aces",
- label = "Check all of the following that you experienced between the ages of 0 and 18:",
- choices = c( "Lived with someone who was depressed, mentally ill, or suicidal" = 1,
- "Lived with someone who was a problem drinker or alcoholic"= 2,
- "Lived with someone who used illegal street drugs or who abused prescription medications" = 3,
- "Live with someone who served time or was sentenced to serve time in a prison, jail, or other correctional facility"= 4,
- "Parents separated or divorced" = 4,
- "Parents or adults in your home slapped, hit, kicked, punched or beat each other up" = 6,
- "Parent or adult in your home hit, beat, kicked, or physically hurt you in any way" = 7,
- "Parent or adult in your home swore at you, insulted you, or put you down" = 8,
- "Someone at least 5 years older than you touched you sexually" = 9,
- "Someone at least 5 years older than you tried to make you touch them sexually" =10,
- "Someone at least 5 years older than you forced you to have sex" =11)),
- #Input age
- numericInput(inputId = "age",
- label = "How old are you?",
- value = 18,
- min = 18,
- max = 100,
- step = 1),
- # Select level of education
- selectInput(inputId = "education",
- label = "Select the highest grade or year of school you have completed",
- choices =c("Never attended school or only kindergarten" = 1,
- "Grades 1 through 8 (Elementary)" = 2,
- "Grades 9 through 11 (Some high school)" = 3,
- "Grade 12 or GED (High school graduate)" = 4,
- "College 1 year to 3 years (Some college or technical school)" = 5,
- "College 4 years or more (College graduate)" = 6)),
- # Select income level
- selectInput(inputId = "income",
- label = "What is your annual household income (from all sources)?",
- choices = c("Less than $10,000" = 1,
- "Between $10,000 and $15,000" = 2,
- "Between $15,000 and $20,000" = 3,
- "Between $20,000 and $25,000" = 4,
- "Between $25,000 and $35,000" = 5,
- "Between $35,000 and $50,000" = 6,
- "Between $50,000 and $75,000" = 7,
- "$75,000 or more" = 8))
- ),
- # Outputs
- mainPanel(
- uiOutput(outputId = "nnet")
- #,br(),
- #plotOutput(outputId = "bar")
- )
- )
- )
- # Define server function
- server <- function(input, output) {
- # Define some reactive components
- # These use the inputs to create vectors that are used in the neural net prediction
- numbers <- reactive({
- validate(
- need(is.numeric(input$age), "Please input your age (in numbers)")
- )
- })
- # aces reactive
- aces_reactive <- reactive({
- aces_list <- replicate(11, 0)
- aces_list[as.integer(input$aces)] = 1
- return(aces_list)
- })
- #vetran reactive
- vetran_reactive <- reactive({
- ifelse(input$vetran, vetran_value <- 1, vetran_value <- 0)
- return(vetran_value)
- })
- # race reactive
- race_reactive <- reactive({
- vec <- replicate(6, 0)
- vec[(as.integer(input$race))]=1
- return(vec)})
- # define the neural network model and python
- source_python("keras_saved_model_update.py")
- py_run_file("keras_saved_model_update.py")
- #A REACTIVE VALUE TO TELL ME WHICH predict function to use then just call that, deifned by input
- #will NEED TO ADD MORE here
- #function reactive
- func <- reactive({
- if (input$health_outcome == "Overweight") {
- return(predict_overweight_nn)
- }
- if (input$health_outcome == "Anxiety") {
- return(predict_anxiety_nn)
- }
- })
- age_reactive <- reactive({
- age <- (input$age-18)/(99-18)
- return(age)
- })
- #score reactive
- score_reactive <- reactive({
- # uses neural net to predict p(outcome) given the information
- predictions = c(aces_reactive(),vetran_reactive(),age_reactive(),input$education,input$income,input$gender,race_reactive())
- score <- (func()(predictions))
- return((score))
- })
- none_reactive <- reactive({
- # uses neural net to predict p(overwieght) given the same demographics but no ACEs
- pred_none = c(replicate(11, 0),vetran_reactive(),age_reactive(),input$education,input$income,input$gender,race_reactive())
- score_none <- (func()(pred_none))
- score_none <- (score_none)
- return(score_none)
- })
- relative_reactive <- reactive({
- relative <- (score_reactive()/none_reactive())
- return(relative)
- })
- #may end up getting rid of this but right now the graphic relies on it
- diff_reactive <- reactive({
- # # calculates difference in real value and if with no ACEs
- diff <- ((score_reactive())-none_reactive())
- return(diff)
- })
- names_reactive <- reactive({
- if (input$health_outcome == "Overweight") {
- return("being overweight")
- }
- if (input$health_outcome == "Anxiety") {
- return("having clinical anxiety")
- }
- })
- incdec_reactive <- reactive({
- if (relative_reactive()-1 > 0) {
- return("higher than")
- }
- if (relative_reactive()-1 < 0) {
- return("lower than")
- }
- if (relative_reactive()-1 == 0) {
- return("which is the same as")
- }
- })
- incdecnew_reactive <- reactive({
- if (relative_reactive()-1 > 0) {
- return(paste(percent(relative_reactive()-1)," higher than",sep=""))
- return("higher than")
- }
- if (relative_reactive()-1 < 0) {
- return(paste(percent(relative_reactive()-1)," lower than",sep=""))
- }
- if (relative_reactive()-1 == 0) {
- return("the same as")
- }
- })
- # create the output of the app
- output$nnet <- renderUI({
- # gives a custom error message if a number is not entered in the age box
- numbers()
- if (sum(aces_reactive()) > 0){
- paste("According to the model and given your information your risk for",
- names_reactive(),
- "is: ",
- paste(percent(score_reactive()),".",sep=""),
- "This risk is",
- incdecnew_reactive(),
- "it would be relative to if you had 0 ACEs.")
- } else {
- paste("According to the model and given your information your risk for",
- names_reactive(),
- "is: ",
- paste(percent(score_reactive()),".",sep=""))
- }
- })
- #this makes the visualization
- #it would be better to have the names
- #can bring this back but right now it feels irrelevant
- # output$bar <- renderPlot({
- # viz <- data.frame(Type = c(paste("Probability of not",names_reactive()), paste("Increased probability of",names_reactive(), "given selected ACEs"), paste("Probability of", names_reactive(), "with your demographics and no ACEs")),
- # Proportion = c((1-score_reactive()), diff_reactive(), (score_reactive()-diff_reactive())))
- # viz <- viz %>%
- # mutate(ace = "Probability of Being Overweight")
- #
- # viz$Type <- factor(viz$Type, levels = viz$Type[c(0:3)])
- #
- # ggplot(viz, aes(x = ace, y = Proportion, fill = Type)) +
- # geom_col() +
- # coord_flip() +
- # #could prob just put in percent(number) instead of proportion + % and hopefully would work
- # geom_text(aes(label = paste0(percent(Proportion))),
- # position = position_stack(vjust = 0.5)) +
- # scale_fill_brewer(palette = "Set2") +
- # theme_minimal(base_size = 14) +
- # ylab("Percentage") +
- # xlab(NULL)
- #
- # })
- }
- # Create a Shiny app object
- shinyApp(ui = ui, server = server)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement