ALM Shiny App Code

Shiny App Simulating ALM and EXAM  

You can play with the embedded version of the app below, or go to direct link

You can adjust the values of the Association parameter (i.e. the c parameter), and the Update parameter, (i.e. the learning rate parameter). The App also allows you to control the number and location of training instances. And the shape of the true function (linear, quadratic or exponential)

Alternatively, you can run the app locally by copying the code below into a .R file.

pacman::p_load(tidyverse,shiny,reactable,shinydashboard,shinydashboardPlus)

input.activation <- function(x.target, association.parameter) {
    return(exp(-1 * association.parameter * (x.target - x.plotting)^2))
}

output.activation <- function(x.target, weights, association.parameter) {
    return(weights %*% input.activation(x.target, association.parameter))
}

mean.prediction <- function(x.target, weights, association.parameter) {
    probability <- output.activation(x.target, weights, association.parameter) / sum(output.activation(x.target, weights, association.parameter))
    return(y.plotting %*% probability)
}
# function to generate exam predictions
exam.prediction <- function(x.target, weights, association.parameter) {
    trainVec <- sort(unique(x.learning))
    nearestTrain <- trainVec[which.min(abs(trainVec - x.target))]
    aresp <- mean.prediction(nearestTrain, weights, association.parameter)
    xUnder <- ifelse(min(trainVec) == nearestTrain, nearestTrain, trainVec[which(trainVec == nearestTrain) - 1])
    xOver <- ifelse(max(trainVec) == nearestTrain, nearestTrain, trainVec[which(trainVec == nearestTrain) + 1])
    mUnder <- mean.prediction(xUnder, weights, association.parameter)
    mOver <- mean.prediction(xOver, weights, association.parameter)
    exam.output <- round(aresp + ((mOver - mUnder) / (xOver - xUnder)) * (x.target - nearestTrain), 3)
    exam.output
}

update.weights <- function(x.new, y.new, weights, association.parameter, update.parameter) {
    y.feedback.activation <- exp(-1 * association.parameter * (y.new - y.plotting)^2)
    x.feedback.activation <- output.activation(x.new, weights, association.parameter)
    return(weights + update.parameter * (y.feedback.activation - x.feedback.activation) %*% t(input.activation(x.new, association.parameter)))
}

learn.alm <- function(y.learning, association.parameter = 0.05, update.parameter = 0.5) {
    weights <- matrix(rep(0.00, length(y.plotting) * length(x.plotting)), nrow = length(y.plotting), ncol = length(x.plotting))
    for (i in 1:length(y.learning)) {
        weights <- update.weights(x.learning[i], y.learning[i], weights, association.parameter, update.parameter)
        weights[weights < 0] <- 0
    }
    alm.predictions <- sapply(x.plotting, mean.prediction, weights = weights, association.parameter = association.parameter)
    exam.predictions <- sapply(x.plotting, exam.prediction, weights = weights, association.parameter = association.parameter)
    return(list(alm.predictions = alm.predictions, exam.predictions = exam.predictions))
    # return(list(alm.predictions=alm.predictions, exam.predictions=exam.predictions,wmFinal=weights))
}



x.plotting <<- seq(0, 90, .5)
y.plotting <<- seq(0, 210, by = 2)
# trainOptions=round(seq(1,length(x.plotting),length.out=21),0)
trainOptions <- x.plotting[seq(1, 181, by = 4)]
trainItems <- trainOptions[c(10, 11, 12)]



# Define UI for application
# 
ui <- dashboardPage(

  skin = "black",
  dashboardHeader(title = "ALM Simulation App"),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Home", tabName = "home", icon = icon("home")),
      menuItem("Code", tabName = "code", icon = icon("code"))
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName = "home",
              fluidRow(
                column(4,
                       box(
                         title = "Simulation Parameters",
                         status = "primary",
                         solidHeader = TRUE,
                         collapsible = TRUE,
                         collapsed = FALSE,
                         width = 12,
                         sliderInput("assoc", "Association Parameter (c):",
                                     min = .001, max = 1, value = 0.5, step = 0.01),
                         sliderInput("update", "Update Parameter:",
                                     min = 0, max = 1, value = 0.5, step = 0.1),
                         sliderInput("trainRep", "Training Repetitions Per Item:",
                                     min = 1, max = 200, value = 1, step = 1),
                         sliderInput("Noise","Noise Level:",
                                     min = 0, max = 50, value = 0.00, step = 1),
                         checkboxGroupInput("trainItems", "Training Items:", choices = trainOptions, selected = trainOptions[c(10,15,35)],inline=TRUE),
                         # radio buttons for selecting function form
                         radioButtons("functionForm", "Function Form:",
                                      choices = c("Linear", "Quadratic", "Exponential"),
                                      selected = "Quadratic"),
                        # numericInput("nRep", "Number of Replications:", value = 1, min = 1, max = 100),
                         actionButton("run", "Run Simulation")
                       )
                ),
                column(8,
                       box(
                         title = "Model Performance",
                         status = "primary",
                         solidHeader = TRUE,
                         collapsible = TRUE,
                         collapsed = FALSE,
                          width = 12,
                         plotOutput("plot"),
                         h5("*Dashed line shows true function. Red shows ALM, and blue depicts EXAM predictions*"),
                         h4("Average Model Performance"),
                         reactableOutput("table"),
                         h4("Model Performance by Item Type"),
                         reactableOutput("table2")
                       )
                )
              )
      ),
      tabItem(tabName = "code",
              fluidRow(
                column(12,
                       box(
                         title = "Code",
                         status = "primary",
                         solidHeader = TRUE,
                         collapsible = TRUE,
                         collapsed = FALSE,
                         width = 12,
                         verbatimTextOutput("code")
                       )
                )
                )
        )
    )
    )
)

# Define server 



server <- function(input, output, session) {
  
  nRep=1
  user_choice <- eventReactive(input$run, {
    return(list(assoc = input$assoc, update = input$update, Noise=input$Noise,
                functionForm=input$functionForm,trainRep = as.numeric(input$trainRep),
                trainItems = input$trainItems))
    
  }, ignoreNULL = FALSE)
  

    output_df <- eventReactive(input$run, {
      uc <- reactive({user_choice()})
    if (uc()$functionForm == "Linear") {
      f.plotting <<- as.numeric(x.plotting * 2.2 + 30)
    } else if (uc()$functionForm == "Quadratic") {
      f.plotting <<- as.numeric(210 - ((x.plotting - 50)^2) / 12)
    } else if (uc()$functionForm == "Exponential") {
      # f.plotting<<-as.numeric(scale(200*(1-exp(-x.plotting/25))))
      f.plotting <<- as.numeric(200 * (1 - exp(-x.plotting / 25)))
    }
    trainItems <- as.numeric(uc()$trainItems)
    y.plotting <<- seq(0, max(f.plotting), by = 1)
    x.learning <<- rep(trainItems, times = uc()$trainRep)
    f.learning <<- rep(f.plotting[which(x.plotting %in% trainItems)], times = uc()$trainRep)
    # print(x.learning)
    # print(f.learning)
    # print(uc()$trainRep)
    # print(trainItems)
    # print(uc()$functionForm)
    
    
    output_list <- replicate(nRep, list(learn.alm(f.learning + rnorm(length(f.learning), sd = uc()$Noise),
                                                  association.parameter = uc()$assoc, update.parameter = uc()$update)))
    
    output_df <- lapply(output_list, function(x) as.data.frame(x))
    #output_df <- lapply(output_list, function(x) lapply(x, as.data.frame)) # 10 dfs x 9 lists
    output_df <- Reduce(rbind, output_df) %>% mutate(x = x.plotting, y = f.plotting)
    #output_df <- lapply(output_df, function(x) Reduce(rbind,x))# 1 df x 9 lists
    output_df <- output_df %>%
      pivot_longer(names_to = "Model", values_to = "Prediction", cols = c(alm.predictions, exam.predictions)) %>%
      rbind(data.frame(data.frame(x = x.plotting, y = f.plotting, Model = "True Function", Prediction = f.plotting)), .)
    #str(output_df)
    return(output_df)
    
    }, ignoreNULL = FALSE)
    
    output$plot <- renderPlot({
      
      output_df2 <- reactive({output_df()})
      ggplot(data = output_df2(), aes(x = x, y = Prediction,color=Model),alpha=.2) + 
        geom_line(aes(linetype=Model,alpha=Model)) + 
        geom_point(data = data.frame(x.learning, f.learning), 
                   aes(x = x.learning,y = f.learning),color="black",size=4,shape=4) +
        # geom_line(data = data.frame(x.plotting, f.plotting), 
        #           aes(x = x.plotting, y = f.plotting),linetype=2, color = "black",alpha=.3) + 
        scale_color_manual(values = c("red", "blue", "black"))+
        scale_alpha_manual(values=c(.8,.8,.4))+
        scale_linetype_manual(values=c(1,1,2))+
        ylim(c(0,250))#+
        # ggtitle(paste("Association Parameter:", user_choice()$assoc, " Update Parameter:", 
        #               uc$update, " Train Reps:", 
        #               uc$trainRep, " Noise:", uc$Noise))
    }) 
    # table 1 reports the summary stats for all items. Table uses GT library to make gt table
    output$table <- renderReactable({
      output_df <- output_df()
      output_df() %>% group_by(Model) %>% filter(Model !="True Function") %>%
        summarise(MeanDeviation = mean(abs(Prediction - y)), 
                  RMSD = sqrt(mean((Prediction -y)^2)),Correlation = cor(Prediction, y)) %>%
        mutate(across(where(is.numeric), round, 1)) %>%
        reactable::reactable(compact=TRUE,bordered = TRUE, highlight = TRUE, resizable=TRUE)
    })
    # table 2 reports the summary stats separately for training items, interpolation items, and extrapolation items
    output$table2 <- renderReactable({
      uc <- reactive({user_choice()})
      output_df() %>% filter(Model !="True Function") %>% 
        mutate(ItemType = ifelse(x %in% x.learning, "Training", ifelse(x > min(x.learning) & x < max(x.learning), "Interpolation", "Extrapolation"))) %>%
        group_by(ItemType,Model) %>%
        summarise(MeanDeviation = mean(abs(Prediction - y)), 
                  RMSD = sqrt(mean((Prediction -y)^2)),Correlation = cor(Prediction, y),
                  .groups="keep") %>% 
        mutate(across(where(is.numeric), round, 1)) %>%
        reactable::reactable(compact=TRUE,bordered = TRUE, highlight = TRUE, resizable=TRUE) 
    })
    
    
    output$code <- renderPrint({
      # code to implement the ALM and EXAM models
      # code to generate data
      # code to run models
      # code to format output
      cat(" input.activation<-function(x.target, association.parameter){
  return(exp(-1*association.parameter*(x.target-x.plotting)^2))
}

output.activation<-function(x.target, weights, association.parameter){
  return(weights%*%input.activation(x.target, association.parameter))
}

mean.prediction<-function(x.target, weights, association.parameter){
  probability<-output.activation(x.target, weights, association.parameter)/sum(output.activation(x.target, weights, association.parameter))
  return(y.plotting%*%probability)
}
# function to generate exam predictions
exam.prediction<-function(x.target, weights, association.parameter){
  trainVec = sort(unique(x.learning))
  nearestTrain = trainVec[which.min(abs(trainVec-x.target))]
  aresp = mean.prediction(nearestTrain, weights, association.parameter)
  xUnder = ifelse(min(trainVec) == nearestTrain, nearestTrain, trainVec[which(trainVec == nearestTrain) - 1])
  xOver = ifelse(max(trainVec) == nearestTrain, nearestTrain, trainVec[which(trainVec == nearestTrain) + 1])
  mUnder = mean.prediction(xUnder, weights, association.parameter)
  mOver = mean.prediction(xOver, weights, association.parameter)
  exam.output = round(aresp + ((mOver - mUnder) / (xOver - xUnder)) * (x.target - nearestTrain), 3)
  exam.output
}

update.weights<-function(x.new, y.new, weights, association.parameter, update.parameter){
  y.feedback.activation<-exp(-1*association.parameter*(y.new-y.plotting)^2)
  x.feedback.activation<-output.activation(x.new, weights, association.parameter)
  return(weights+update.parameter*(y.feedback.activation-x.feedback.activation)%*%t(input.activation(x.new, association.parameter)))
}

learn.alm<-function(y.learning, association.parameter=0.05, update.parameter=0.5){
  weights<-matrix(rep(0.00, length(y.plotting)*length(x.plotting)), nrow=length(y.plotting), ncol=length(x.plotting))
  for (i in 1:length(y.learning)){
    weights<-update.weights(x.learning[i], y.learning[i], weights, association.parameter, update.parameter)
    weights[weights<0]=0
  }
  alm.predictions<-sapply(x.plotting, mean.prediction, weights=weights, association.parameter=association.parameter)
  exam.predictions <- sapply(x.plotting, exam.prediction, weights=weights, association.parameter=association.parameter)
  return(list(alm.predictions=alm.predictions, exam.predictions=exam.predictions))
  #return(list(alm.predictions=alm.predictions, exam.predictions=exam.predictions,wmFinal=weights))
}

    ")
    })
    
}



# Run the application


shinyApp(ui, server)