cjerzak commited on
Commit
a22e188
·
verified ·
1 Parent(s): c76a52d

Update app.R

Browse files
Files changed (1) hide show
  1. app.R +114 -87
app.R CHANGED
@@ -2,9 +2,8 @@
2
 
3
  library(shiny)
4
  library(dplyr)
5
- library(plotly)
6
  library(fields) # For image.plot in heatMap
7
- library(akima) # For interpolation in heatMap
8
 
9
  # Load the data from sm.csv
10
  sm <- read.csv("sm.csv")
@@ -16,7 +15,7 @@ f2n <- function(x) as.numeric(as.character(x))
16
  sm$MaxImageDimsLeft <- unlist(lapply(strsplit(sm$MaxImageDims, split = "_"), function(x) sort(f2n(x))[1]))
17
  sm$MaxImageDimsRight <- unlist(lapply(strsplit(sm$MaxImageDims, split = "_"), function(x) sort(f2n(x))[2]))
18
 
19
- # Define the heatMap function (unchanged except for updated default color palette)
20
  heatMap <- function(x, y, z,
21
  main = "",
22
  N, yaxt = NULL,
@@ -40,7 +39,8 @@ heatMap <- function(x, y, z,
40
  includeMarginals = FALSE,
41
  marginalJitterSD_x = 0.01,
42
  marginalJitterSD_y = 0.01,
43
- openBrowser = FALSE) {
 
44
  if (openBrowser) { browser() }
45
  s_ <- akima::interp(x = x, y = y, z = z,
46
  xo = seq(min(x), max(x), length = N),
@@ -78,11 +78,16 @@ heatMap <- function(x, y, z,
78
  points(rep(xlim[1] * 1.1, length(x)),
79
  y + rnorm(length(y), sd = sd(y) * marginalJitterSD_y), pch = "-", col = "darkgray")
80
  }
 
 
 
 
 
81
  }
82
 
83
  # UI Definition
84
  ui <- fluidPage(
85
- titlePanel("Multiscale Heatmap & Surface Explorer"),
86
  sidebarLayout(
87
  sidebarPanel(
88
  selectInput("application", "Application",
@@ -91,27 +96,29 @@ ui <- fluidPage(
91
  selectInput("model", "Model",
92
  choices = unique(sm$optimizeImageRep),
93
  selected = "clip"),
94
- # Removed "Perturb Center" input
95
  selectInput("metric", "Metric",
96
  choices = c("AUTOC_rate_std_ratio_mean", "AUTOC_rate_mean", "AUTOC_rate_std_mean",
97
  "AUTOC_rate_std_ratio_mean_pc", "AUTOC_rate_mean_pc", "AUTOC_rate_std_mean_pc",
98
  "MeanVImportHalf1", "MeanVImportHalf2", "FracTopkHalf1", "RMSE"),
99
  selected = "AUTOC_rate_std_ratio_mean"),
100
- radioButtons("plotType", "Plot Type",
101
- choices = c("Heatmap", "Surface"),
102
- selected = "Heatmap")
103
  ),
104
  mainPanel(
105
- uiOutput("plotOutput")
106
  )
107
  )
108
  )
109
 
110
  # Server Definition
111
  server <- function(input, output) {
 
 
 
 
 
 
112
  # Reactive data processing
113
  filteredData <- reactive({
114
- # Removed filtering by 'perturbCenter'
115
  df <- sm %>%
116
  filter(application == input$application,
117
  optimizeImageRep == input$model) %>%
@@ -122,26 +129,12 @@ server <- function(input, output) {
122
  df
123
  })
124
 
125
- # Render the plot output dynamically
126
- output$plotOutput <- renderUI({
127
- data <- filteredData()
128
- if (is.null(data)) {
129
- return(tags$p("No data available for the selected filters."))
130
- }
131
-
132
- if (input$plotType == "Heatmap") {
133
- plotOutput("heatmapPlot", height = "600px")
134
- } else {
135
- plotlyOutput("surfacePlot", height = "600px")
136
- }
137
- })
138
-
139
- # Heatmap Output
140
- output$heatmapPlot <- renderPlot({
141
  data <- filteredData()
142
  if (is.null(data)) return(NULL)
143
 
144
- # Group data for heatmap
145
  grouped_data <- data %>%
146
  group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
147
  summarise(
@@ -151,81 +144,115 @@ server <- function(input, output) {
151
  .groups = "drop"
152
  )
153
 
154
- # Check for sufficient data points for interpolation
155
- if (nrow(grouped_data) < 3) {
156
- plot.new()
157
- text(0.5, 0.5, "Insufficient data points for interpolation", cex = 1.5)
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
158
  } else {
159
- x <- grouped_data$MaxImageDimsLeft
160
- y <- grouped_data$MaxImageDimsRight
161
- z <- grouped_data$mean_metric
162
-
163
- # Slightly more appealing color palette
164
- customPalette <- colorRampPalette(c("blue", "white", "red"))(50)
165
-
166
- heatMap(x = x,
167
- y = y,
168
- z = z,
169
- N = 50,
170
- main = paste(input$application, "-", input$metric),
171
- # More descriptive axis labels
172
- xlab = "Maximum Image Dimensions (Left)",
173
- ylab = "Maximum Image Dimensions (Right)",
174
- useLog = "xy",
175
- myCol = customPalette,
176
- cex.lab = 1.4)
177
  }
 
 
 
 
 
 
 
 
 
 
178
  })
179
 
180
- # Surface Plot Output
181
- output$surfacePlot <- renderPlotly({
182
- data <- filteredData()
183
- if (is.null(data)) return(NULL)
 
 
 
 
184
 
185
- # Group data for surface plot
186
  grouped_data <- data %>%
187
  group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
188
  summarise(
189
  mean_metric = mean(as.numeric(get(input$metric)), na.rm = TRUE),
190
- se_metric = sd(as.numeric(get(input$metric)), na.rm = TRUE) / sqrt(n()),
191
- n = n(),
192
  .groups = "drop"
193
  )
194
 
195
- # Create grid for surface plot
196
- all_scales <- sort(unique(c(grouped_data$MaxImageDimsLeft, grouped_data$MaxImageDimsRight)))
197
- z_matrix <- matrix(NA, nrow = length(all_scales), ncol = length(all_scales))
198
- tooltip_matrix <- matrix("", nrow = length(all_scales), ncol = length(all_scales))
 
 
199
 
200
- for (i in 1:nrow(grouped_data)) {
201
- left_idx <- which(all_scales == grouped_data$MaxImageDimsLeft[i])
202
- right_idx <- which(all_scales == grouped_data$MaxImageDimsRight[i])
203
- z_matrix[left_idx, right_idx] <- grouped_data$mean_metric[i]
204
- tooltip_matrix[left_idx, right_idx] <- sprintf("Mean: %.2f<br>SE: %.2f<br>n: %d",
205
- grouped_data$mean_metric[i],
206
- grouped_data$se_metric[i],
207
- grouped_data$n[i])
 
 
 
 
 
 
 
 
 
 
208
  }
209
 
210
- # Render interactive 3D surface plot
211
- plot_ly(
212
- x = all_scales,
213
- y = all_scales,
214
- z = z_matrix,
215
- type = "surface",
216
- text = tooltip_matrix,
217
- hoverinfo = "text"
218
- ) %>%
219
- layout(
220
- title = paste("Surface Plot for", input$metric, "in", input$application),
221
- scene = list(
222
- xaxis = list(title = "Maximum Image Dimensions (Right)"),
223
- yaxis = list(title = "Maximum Image Dimensions (Left)"),
224
- zaxis = list(title = input$metric)
225
- )
226
- )
227
  })
228
  }
229
 
230
  # Run the Shiny App
231
- shinyApp(ui = ui, server = server)
 
2
 
3
  library(shiny)
4
  library(dplyr)
 
5
  library(fields) # For image.plot in heatMap
6
+ library(akima) # For interpolation
7
 
8
  # Load the data from sm.csv
9
  sm <- read.csv("sm.csv")
 
15
  sm$MaxImageDimsLeft <- unlist(lapply(strsplit(sm$MaxImageDims, split = "_"), function(x) sort(f2n(x))[1]))
16
  sm$MaxImageDimsRight <- unlist(lapply(strsplit(sm$MaxImageDims, split = "_"), function(x) sort(f2n(x))[2]))
17
 
18
+ # Heatmap function with optimal_point parameter
19
  heatMap <- function(x, y, z,
20
  main = "",
21
  N, yaxt = NULL,
 
39
  includeMarginals = FALSE,
40
  marginalJitterSD_x = 0.01,
41
  marginalJitterSD_y = 0.01,
42
+ openBrowser = FALSE,
43
+ optimal_point = NULL) {
44
  if (openBrowser) { browser() }
45
  s_ <- akima::interp(x = x, y = y, z = z,
46
  xo = seq(min(x), max(x), length = N),
 
78
  points(rep(xlim[1] * 1.1, length(x)),
79
  y + rnorm(length(y), sd = sd(y) * marginalJitterSD_y), pch = "-", col = "darkgray")
80
  }
81
+
82
+ # Add green star at optimal point if provided
83
+ if (!is.null(optimal_point)) {
84
+ points(optimal_point$x, optimal_point$y, pch = 8, col = "green", cex = 3, lwd = 4)
85
+ }
86
  }
87
 
88
  # UI Definition
89
  ui <- fluidPage(
90
+ titlePanel("Multiscale Heatmap Explorer"),
91
  sidebarLayout(
92
  sidebarPanel(
93
  selectInput("application", "Application",
 
96
  selectInput("model", "Model",
97
  choices = unique(sm$optimizeImageRep),
98
  selected = "clip"),
 
99
  selectInput("metric", "Metric",
100
  choices = c("AUTOC_rate_std_ratio_mean", "AUTOC_rate_mean", "AUTOC_rate_std_mean",
101
  "AUTOC_rate_std_ratio_mean_pc", "AUTOC_rate_mean_pc", "AUTOC_rate_std_mean_pc",
102
  "MeanVImportHalf1", "MeanVImportHalf2", "FracTopkHalf1", "RMSE"),
103
  selected = "AUTOC_rate_std_ratio_mean"),
104
+ checkboxInput("compareToBest", "Compare to best single scale", value = FALSE)
 
 
105
  ),
106
  mainPanel(
107
+ plotOutput("heatmapPlot", height = "600px")
108
  )
109
  )
110
  )
111
 
112
  # Server Definition
113
  server <- function(input, output) {
114
+ # Function to determine whether to maximize or minimize the metric
115
+ get_better_direction <- function(metric) {
116
+ #if (grepl("std|RMSE", metric)) "min" else "max"
117
+ if (grepl(metric, pattern = "std_mean|RMSE")) "min" else "max"
118
+ }
119
+
120
  # Reactive data processing
121
  filteredData <- reactive({
 
122
  df <- sm %>%
123
  filter(application == input$application,
124
  optimizeImageRep == input$model) %>%
 
129
  df
130
  })
131
 
132
+ # Reactive expression to compute interpolated data and optimal point
133
+ interpolated_data <- reactive({
 
 
 
 
 
 
 
 
 
 
 
 
 
 
134
  data <- filteredData()
135
  if (is.null(data)) return(NULL)
136
 
137
+ # Group data
138
  grouped_data <- data %>%
139
  group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
140
  summarise(
 
144
  .groups = "drop"
145
  )
146
 
147
+ better_dir <- get_better_direction(input$metric)
148
+ single_scale_data <- grouped_data %>% filter(MaxImageDimsLeft == MaxImageDimsRight)
149
+ best_single_scale_metric <- if (nrow(single_scale_data) > 0) {
150
+ if (better_dir == "max") max(single_scale_data$mean_metric, na.rm = TRUE)
151
+ else min(single_scale_data$mean_metric, na.rm = TRUE)
152
+ } else NA
153
+
154
+ grouped_data <- grouped_data %>%
155
+ mutate(improvement = if (better_dir == "max") {
156
+ mean_metric - best_single_scale_metric
157
+ } else {
158
+ best_single_scale_metric - mean_metric
159
+ })
160
+
161
+ # Select z based on checkbox
162
+ z_to_interpolate <- if (input$compareToBest) grouped_data$improvement else grouped_data$mean_metric
163
+ x <- grouped_data$MaxImageDimsLeft
164
+ y <- grouped_data$MaxImageDimsRight
165
+
166
+ # Check if interpolation is possible
167
+ if (length(unique(x)) < 2 || length(unique(y)) < 2 || nrow(grouped_data) < 3) {
168
+ return(NULL)
169
+ }
170
+
171
+ # Compute interpolated grid
172
+ s_ <- akima::interp(x = x,
173
+ y = y,
174
+ z = z_to_interpolate,
175
+ xo = seq(min(x), max(x), length = 50),
176
+ yo = seq(min(y), max(y), length = 50),
177
+ duplicate = "mean")
178
+
179
+ # Find optimal point from interpolated grid
180
+ max_idx <- if (input$compareToBest || better_dir == "max") {
181
+ which.max(s_$z)
182
  } else {
183
+ which.min(s_$z)
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
184
  }
185
+
186
+ row_col <- arrayInd(max_idx, .dim = dim(s_$z))
187
+ optimal_x <- s_$x[row_col[1,1]]
188
+ optimal_y <- s_$y[row_col[1,2]]
189
+ optimal_z <- s_$z[row_col[1,1], row_col[1,2]]
190
+
191
+ list(s_ = s_,
192
+ optimal_point = list(x = optimal_x,
193
+ y = optimal_y,
194
+ z = optimal_z))
195
  })
196
 
197
+ # Heatmap Output
198
+ output$heatmapPlot <- renderPlot({
199
+ interp_data <- interpolated_data()
200
+ if (is.null(interp_data)) {
201
+ plot.new()
202
+ text(0.5, 0.5, "Insufficient data for interpolation", cex = 1.5)
203
+ return(NULL)
204
+ }
205
 
206
+ data <- filteredData()
207
  grouped_data <- data %>%
208
  group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
209
  summarise(
210
  mean_metric = mean(as.numeric(get(input$metric)), na.rm = TRUE),
 
 
211
  .groups = "drop"
212
  )
213
 
214
+ better_dir <- get_better_direction(input$metric)
215
+ single_scale_data <- grouped_data %>% filter(MaxImageDimsLeft == MaxImageDimsRight)
216
+ best_single_scale_metric <- if (nrow(single_scale_data) > 0) {
217
+ if (better_dir == "max") max(single_scale_data$mean_metric, na.rm = TRUE)
218
+ else min(single_scale_data$mean_metric, na.rm = TRUE)
219
+ } else NA
220
 
221
+ grouped_data <- grouped_data %>%
222
+ mutate(improvement = if (better_dir == "max") {
223
+ mean_metric - best_single_scale_metric
224
+ } else {
225
+ best_single_scale_metric - mean_metric
226
+ })
227
+
228
+ x <- grouped_data$MaxImageDimsLeft
229
+ y <- grouped_data$MaxImageDimsRight
230
+ if (input$compareToBest) {
231
+ z <- grouped_data$improvement
232
+ main <- paste(input$application, "-", input$metric, "improvement over best single scale")
233
+ max_abs <- max(abs(z), na.rm = TRUE)
234
+ zlim <- if (!is.na(max_abs)) c(-max_abs, max_abs) else NULL
235
+ } else {
236
+ z <- grouped_data$mean_metric
237
+ main <- paste(input$application, "-", input$metric)
238
+ zlim <- range(z, na.rm = TRUE) # Changed from zlim <- NULL
239
  }
240
 
241
+ customPalette <- colorRampPalette(c("blue", "white", "red"))(50)
242
+ heatMap(x = x,
243
+ y = y,
244
+ z = z,
245
+ N = 50,
246
+ main = main,
247
+ xlab = "Image Dimension 1",
248
+ ylab = "Image Dimensions 2",
249
+ useLog = "xy",
250
+ myCol = customPalette,
251
+ cex.lab = 1.4,
252
+ zlim = zlim,
253
+ optimal_point = interp_data$optimal_point)
 
 
 
 
254
  })
255
  }
256
 
257
  # Run the Shiny App
258
+ shinyApp(ui = ui, server = server)