cjerzak commited on
Commit
aea85e3
·
verified ·
1 Parent(s): 356b1c6

Create warmup/app_v1.R

Browse files
Files changed (1) hide show
  1. warmup/app_v1.R +457 -0
warmup/app_v1.R ADDED
@@ -0,0 +1,457 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
1
+ # setwd('~/Dropbox/ImageSeq/')
2
+
3
+ options(error = NULL)
4
+ library(shiny)
5
+ library(dplyr)
6
+ library(fields) # For image.plot in heatMap
7
+ library(akima) # For interpolation
8
+
9
+ # Load the data from sm.csv
10
+ sm <- read.csv("sm.csv")
11
+
12
+ # Define function to convert to numeric
13
+ f2n <- function(x) as.numeric(as.character(x))
14
+
15
+ # Compute MaxImageDimsLeft and MaxImageDimsRight from MaxImageDims
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
+ # Heatmap function with optimal_point parameter
20
+ heatMap <- function(x, y, z,
21
+ main = "",
22
+ N, yaxt = NULL,
23
+ xlab = "",
24
+ ylab = "",
25
+ horizontal = FALSE,
26
+ useLog = "",
27
+ legend.width = 1,
28
+ ylim = NULL,
29
+ xlim = NULL,
30
+ zlim = NULL,
31
+ add.legend = TRUE,
32
+ legend.only = FALSE,
33
+ vline = NULL,
34
+ col_vline = "black",
35
+ hline = NULL,
36
+ col_hline = "black",
37
+ cex.lab = 2,
38
+ cex.main = 2,
39
+ myCol = NULL,
40
+ includeMarginals = FALSE,
41
+ marginalJitterSD_x = 0.01,
42
+ marginalJitterSD_y = 0.01,
43
+ openBrowser = FALSE,
44
+ optimal_point = NULL) {
45
+ if (openBrowser) { browser() }
46
+ s_ <- akima::interp(x = x, y = y, z = z,
47
+ xo = seq(min(x), max(x), length = N),
48
+ yo = seq(min(y), max(y), length = N),
49
+ duplicate = "mean")
50
+ if (is.null(xlim)) { xlim = range(s_$x, finite = TRUE) }
51
+ if (is.null(ylim)) { ylim = range(s_$y, finite = TRUE) }
52
+ imageFxn <- if (add.legend) fields::image.plot else graphics::image
53
+ if (!grepl(useLog, pattern = "z")) {
54
+ imageFxn(s_, xlab = xlab, ylab = ylab, log = useLog, cex.lab = cex.lab, main = main,
55
+ cex.main = cex.main, col = myCol, xlim = xlim, ylim = ylim,
56
+ legend.width = legend.width, horizontal = horizontal, yaxt = yaxt,
57
+ zlim = zlim, legend.only = legend.only)
58
+ } else {
59
+ useLog <- gsub(useLog, pattern = "z", replace = "")
60
+ zTicks <- summary(c(s_$z))
61
+ ep_ <- 0.001
62
+ zTicks[zTicks < ep_] <- ep_
63
+ zTicks <- exp(seq(log(min(zTicks)), log(max(zTicks)), length.out = 10))
64
+ zTicks <- round(zTicks, abs(min(log(zTicks, base = 10))))
65
+ s_$z[s_$z < ep_] <- ep_
66
+ imageFxn(s_$x, s_$y, log(s_$z), yaxt = yaxt,
67
+ axis.args = list(at = log(zTicks), labels = zTicks),
68
+ main = main, cex.main = cex.main, xlab = xlab, ylab = ylab,
69
+ log = useLog, cex.lab = cex.lab, xlim = xlim, ylim = ylim,
70
+ horizontal = horizontal, col = myCol, legend.width = legend.width,
71
+ zlim = zlim, legend.only = legend.only)
72
+ }
73
+ if (!is.null(vline)) { abline(v = vline, lwd = 10, col = col_vline) }
74
+ if (!is.null(hline)) { abline(h = hline, lwd = 10, col = col_hline) }
75
+
76
+ if (includeMarginals) {
77
+ points(x + rnorm(length(y), sd = marginalJitterSD_x * sd(x)),
78
+ rep(ylim[1] * 1.1, length(y)), pch = "|", col = "darkgray")
79
+ points(rep(xlim[1] * 1.1, length(x)),
80
+ y + rnorm(length(y), sd = sd(y) * marginalJitterSD_y), pch = "-", col = "darkgray")
81
+ }
82
+
83
+ # Add green star at optimal point if provided
84
+ if (!is.null(optimal_point)) {
85
+ points(optimal_point$x, optimal_point$y, pch = 8, col = "green", cex = 3, lwd = 4)
86
+ }
87
+ }
88
+
89
+ ##############################################################################
90
+ # IMPORTANT: Store the meaningful labels for metric in a named vector.
91
+ # The "name" is what is displayed to the user in the dropdown,
92
+ # while the "value" is the underlying column in the dataset.
93
+ ##############################################################################
94
+ metric_choices <- c(
95
+ "Mean AUTOC RATE Ratio" = "AUTOC_rate_std_ratio_mean",
96
+ "Mean AUTOC RATE" = "AUTOC_rate_mean",
97
+ "Mean SD of AUTOC RATE" = "AUTOC_rate_std_mean",
98
+ "Mean AUTOC RATE Ratio with PC" = "AUTOC_rate_std_ratio_mean_pc",
99
+ "Mean AUTOC RATE with PC" = "AUTOC_rate_mean_pc",
100
+ "Mean SD of AUTOC RATE with PC" = "AUTOC_rate_std_mean_pc",
101
+ "Mean Variable Importance (Image 1)" = "MeanVImportHalf1",
102
+ "Mean Variable Importance (Image 2)" = "MeanVImportHalf2",
103
+ "Mean Fraction of Top k Features (Image 1)" = "FracTopkHalf1",
104
+ "Mean RMSE" = "RMSE"
105
+ )
106
+
107
+ ##############################################################################
108
+ # Helper function to retrieve the *label* from its code
109
+ ##############################################################################
110
+ getMetricLabel <- function(metric_value) {
111
+ # This returns, e.g., "Mean AUTOC RATE" if metric_value == "AUTOC_rate_mean".
112
+ # If it doesn't find a match, return the code itself.
113
+ lbl <- names(metric_choices)[which(metric_choices == metric_value)]
114
+ if (length(lbl) == 0) return(metric_value)
115
+ lbl
116
+ }
117
+
118
+ # UI Definition
119
+ ui <- fluidPage(
120
+ titlePanel("Multiscale Representations Explorer"),
121
+
122
+ tags$p(
123
+ style = "text-align: left; margin-top: -10px;",
124
+ tags$a(
125
+ href = "https://planetarycausalinference.org/",
126
+ target = "_blank",
127
+ title = "PlanetaryCausalInference.org",
128
+ style = "color: #337ab7; text-decoration: none;",
129
+ "PlanetaryCausalInference.org ",
130
+ icon("external-link", style = "font-size: 12px;")
131
+ )
132
+ ),
133
+
134
+ # ---- Here is the minimal "Share" button HTML + JS inlined in Shiny ----
135
+ # We wrap it in tags$div(...) and tags$script(HTML(...)) so it is recognized
136
+ # by Shiny. You can adjust the styling or placement as needed.
137
+ tags$div(
138
+ style = "text-align: left; margin: 1em 0 1em 0em;",
139
+ HTML('
140
+ <button id="share-button"
141
+ style="
142
+ display: inline-flex;
143
+ align-items: center;
144
+ justify-content: center;
145
+ gap: 8px;
146
+ padding: 5px 10px;
147
+ font-size: 16px;
148
+ font-weight: normal;
149
+ color: #000;
150
+ background-color: #fff;
151
+ border: 1px solid #ddd;
152
+ border-radius: 6px;
153
+ cursor: pointer;
154
+ box-shadow: 0 1.5px 0 #000;
155
+ ">
156
+ <svg width="18" height="18" viewBox="0 0 24 24" fill="none" stroke="currentColor"
157
+ stroke-width="2" stroke-linecap="round" stroke-linejoin="round">
158
+ <circle cx="18" cy="5" r="3"></circle>
159
+ <circle cx="6" cy="12" r="3"></circle>
160
+ <circle cx="18" cy="19" r="3"></circle>
161
+ <line x1="8.59" y1="13.51" x2="15.42" y2="17.49"></line>
162
+ <line x1="15.41" y1="6.51" x2="8.59" y2="10.49"></line>
163
+ </svg>
164
+ <strong>Share</strong>
165
+ </button>
166
+ '),
167
+ # Insert the JS as well
168
+ tags$script(
169
+ HTML("
170
+ (function() {
171
+ const shareBtn = document.getElementById('share-button');
172
+ // Reusable helper function to show a small “Copied!” message
173
+ function showCopyNotification() {
174
+ const notification = document.createElement('div');
175
+ notification.innerText = 'Copied to clipboard';
176
+ notification.style.position = 'fixed';
177
+ notification.style.bottom = '20px';
178
+ notification.style.right = '20px';
179
+ notification.style.backgroundColor = 'rgba(0, 0, 0, 0.8)';
180
+ notification.style.color = '#fff';
181
+ notification.style.padding = '8px 12px';
182
+ notification.style.borderRadius = '4px';
183
+ notification.style.zIndex = '9999';
184
+ document.body.appendChild(notification);
185
+ setTimeout(() => { notification.remove(); }, 2000);
186
+ }
187
+ shareBtn.addEventListener('click', function() {
188
+ const currentURL = window.location.href;
189
+ const pageTitle = document.title || 'Check this out!';
190
+ // If browser supports Web Share API
191
+ if (navigator.share) {
192
+ navigator.share({
193
+ title: pageTitle,
194
+ text: '',
195
+ url: currentURL
196
+ })
197
+ .catch((error) => {
198
+ console.log('Sharing failed', error);
199
+ });
200
+ } else {
201
+ // Fallback: Copy URL
202
+ if (navigator.clipboard && navigator.clipboard.writeText) {
203
+ navigator.clipboard.writeText(currentURL).then(() => {
204
+ showCopyNotification();
205
+ }, (err) => {
206
+ console.error('Could not copy text: ', err);
207
+ });
208
+ } else {
209
+ // Double fallback for older browsers
210
+ const textArea = document.createElement('textarea');
211
+ textArea.value = currentURL;
212
+ document.body.appendChild(textArea);
213
+ textArea.select();
214
+ try {
215
+ document.execCommand('copy');
216
+ showCopyNotification();
217
+ } catch (err) {
218
+ alert('Please copy this link:\\n' + currentURL);
219
+ }
220
+ document.body.removeChild(textArea);
221
+ }
222
+ }
223
+ });
224
+ })();
225
+ ")
226
+ )
227
+ ),
228
+ # ---- End: Minimal Share button snippet ----
229
+
230
+
231
+ sidebarLayout(
232
+ sidebarPanel(
233
+ selectInput("application", "Application",
234
+ choices = unique(sm$application),
235
+ selected = unique(sm$application)[1]),
236
+ selectInput("model", "Model",
237
+ choices = unique(sm$optimizeImageRep),
238
+ selected = "clip-rsicd"),
239
+
240
+ ########################################################################
241
+ # Use our named vector 'metric_choices' directly in selectInput
242
+ ########################################################################
243
+ selectInput("metric", "Metric",
244
+ choices = metric_choices,
245
+ selected = "AUTOC_rate_std_ratio_mean"),
246
+
247
+ checkboxInput("compareToBest", "Compare to best single scale", value = FALSE)
248
+ ),
249
+ mainPanel(
250
+ plotOutput("heatmapPlot", height = "600px"),
251
+ div(style = "margin-top: 10px; font-style: italic;", uiOutput("contextNote"))
252
+ )
253
+ )
254
+ )
255
+
256
+ # Server Definition
257
+ server <- function(input, output) {
258
+ # Function to determine whether to maximize or minimize the metric
259
+ get_better_direction <- function(metric) {
260
+ #if (grepl("std|RMSE", metric)) "min" else "max"
261
+ if (grepl(metric, pattern = "std_mean|RMSE")) "min" else "max"
262
+ }
263
+
264
+ # Reactive data processing
265
+ filteredData <- reactive({
266
+ df <- sm %>%
267
+ filter(application == input$application,
268
+ optimizeImageRep == input$model) %>%
269
+ mutate(MaxImageDimsRight = ifelse(is.na(MaxImageDimsRight),
270
+ MaxImageDimsLeft,
271
+ MaxImageDimsRight))
272
+ if (nrow(df) == 0) return(NULL)
273
+ df
274
+ })
275
+
276
+ # Reactive expression to compute interpolated data and optimal point
277
+ interpolated_data <- reactive({
278
+ data <- filteredData()
279
+ if (is.null(data)) return(NULL)
280
+
281
+ # Group data
282
+ grouped_data <- data %>%
283
+ group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
284
+ summarise(
285
+ mean_metric = mean(as.numeric(get(input$metric)), na.rm = TRUE),
286
+ se_metric = sd(as.numeric(get(input$metric)), na.rm = TRUE) / sqrt(n()),
287
+ n = n(),
288
+ .groups = "drop"
289
+ )
290
+
291
+ better_dir <- get_better_direction(input$metric)
292
+ single_scale_data <- grouped_data %>% filter(MaxImageDimsLeft == MaxImageDimsRight)
293
+ best_single_scale_metric <- if (nrow(single_scale_data) > 0) {
294
+ if (better_dir == "max") max(single_scale_data$mean_metric, na.rm = TRUE)
295
+ else min(single_scale_data$mean_metric, na.rm = TRUE)
296
+ } else NA
297
+
298
+ grouped_data <- grouped_data %>%
299
+ mutate(improvement = if (better_dir == "max") {
300
+ mean_metric - best_single_scale_metric
301
+ } else {
302
+ best_single_scale_metric - mean_metric
303
+ })
304
+
305
+ # Select z based on checkbox
306
+ z_to_interpolate <- if (input$compareToBest) grouped_data$improvement else grouped_data$mean_metric
307
+ x <- grouped_data$MaxImageDimsLeft
308
+ y <- grouped_data$MaxImageDimsRight
309
+
310
+ # Check if interpolation is possible
311
+ if (length(unique(x)) < 2 || length(unique(y)) < 2 || nrow(grouped_data) < 3) {
312
+ return(NULL)
313
+ }
314
+
315
+ # Compute interpolated grid
316
+ s_ <- akima::interp(
317
+ x = x,
318
+ y = y,
319
+ z = z_to_interpolate,
320
+ xo = seq(min(x), max(x), length = 50),
321
+ yo = seq(min(y), max(y), length = 50),
322
+ duplicate = "mean"
323
+ )
324
+
325
+ # Find optimal point from interpolated grid
326
+ max_idx <- if (input$compareToBest || better_dir == "max") {
327
+ which.max(s_$z)
328
+ } else {
329
+ which.min(s_$z)
330
+ }
331
+ row_col <- arrayInd(max_idx, .dim = dim(s_$z))
332
+ optimal_x <- s_$x[row_col[1,1]]
333
+ optimal_y <- s_$y[row_col[1,2]]
334
+ optimal_z <- s_$z[row_col[1,1], row_col[1,2]]
335
+
336
+ list(
337
+ s_ = s_,
338
+ optimal_point = list(x = optimal_x, y = optimal_y, z = optimal_z)
339
+ )
340
+ })
341
+
342
+ # Heatmap Output
343
+ output$heatmapPlot <- renderPlot({
344
+ interp_data <- interpolated_data()
345
+ if (is.null(interp_data)) {
346
+ plot.new()
347
+ text(0.5, 0.5, "Insufficient data for interpolation", cex = 1.5)
348
+ return(NULL)
349
+ }
350
+
351
+ data <- filteredData()
352
+ grouped_data <- data %>%
353
+ group_by(MaxImageDimsLeft, MaxImageDimsRight) %>%
354
+ summarise(
355
+ mean_metric = mean(as.numeric(get(input$metric)), na.rm = TRUE),
356
+ .groups = "drop"
357
+ )
358
+
359
+ better_dir <- get_better_direction(input$metric)
360
+ single_scale_data <- grouped_data %>% filter(MaxImageDimsLeft == MaxImageDimsRight)
361
+ best_single_scale_metric <- if (nrow(single_scale_data) > 0) {
362
+ if (better_dir == "max") max(single_scale_data$mean_metric, na.rm = TRUE)
363
+ else min(single_scale_data$mean_metric, na.rm = TRUE)
364
+ } else NA
365
+
366
+ grouped_data <- grouped_data %>%
367
+ mutate(improvement = if (better_dir == "max") {
368
+ mean_metric - best_single_scale_metric
369
+ } else {
370
+ best_single_scale_metric - mean_metric
371
+ })
372
+
373
+ # Retrieve the *label* for the chosen metric:
374
+ chosen_metric_label <- getMetricLabel(input$metric)
375
+
376
+ if (input$compareToBest) {
377
+ z <- grouped_data$improvement
378
+ main_title <- paste(input$application, "-", chosen_metric_label, "\n Improvement Over Best Single Scale")
379
+ } else {
380
+ z <- grouped_data$mean_metric
381
+ main_title <- paste(input$application, "-", chosen_metric_label)
382
+ }
383
+
384
+ x <- grouped_data$MaxImageDimsLeft
385
+ y <- grouped_data$MaxImageDimsRight
386
+ zlim <- range(z, na.rm = TRUE)
387
+
388
+ par(mar=c(5,5,5,1))
389
+ customPalette <- colorRampPalette(c("blue", "white", "red"))(50)
390
+ heatMap(
391
+ x = x,
392
+ y = y,
393
+ z = z,
394
+ N = 50,
395
+ main = main_title,
396
+ xlab = "Image Dimension 1",
397
+ ylab = "Image Dimension 2",
398
+ useLog = "xy",
399
+ myCol = customPalette,
400
+ cex.lab = 1.4,
401
+ zlim = zlim,
402
+ optimal_point = interp_data$optimal_point
403
+ )
404
+ })
405
+
406
+ # Contextual Note Output
407
+ output$contextNote <- renderText({
408
+ SharedContextText <- c(
409
+ "The Peru RCT involves a multifaceted graduation program treatment to reduce poverty outcomes.",
410
+ "The Uganda RCT involves a cash grant program to stimulate human capital and living conditions among the poor.",
411
+ "For more information, see the associated paper, <a href='https://arxiv.org/abs/2411.02134' target='_blank'>arXiv.org/abs/2411.02134</a>
412
+ (<a href='https://connorjerzak.com/wp-content/uploads/2024/11/MultilevelBib.txt' target='_blank'>BibTex</a>),
413
+ and <a href='https://www.youtube.com/watch?v=RvAoJGMlKAI' target='_blank'>YouTube tutorial</a>.
414
+ ",
415
+ "<div style='font-size: 10px; line-height: 1.5;'>",
416
+ "<b>Glossary:</b><br>",
417
+ "• <b>Model:</b> The neural-network backbone (e.g., clip-rsicd) transforming satellite images into numerical representations.<br>",
418
+ "• <b>Metric:</b> The criterion (e.g., RATE Ratio, RMSE) measuring performance or heterogeneity detection.<br>",
419
+ "• <b>Compare to best single-scale:</b> Toggle showing metric improvement relative to the best single-scale baseline.<br>",
420
+ "• <b>ImageDim1, ImageDim2:</b> Image sizes (e.g., 64×64, 128×128) for multi-scale analysis.<br>",
421
+ "• <b>RATE Ratio:</b> A t-statistic-like quantity indicating how much a data-model combination captures treatment-effect variation. Ratio of the RATE and its standard error. It can employ two weighting scemes (AUTOC and Qini).<br>",
422
+ "• <b>PC:</b> Principal Components; a compression step of neural representations.<br>",
423
+ "• <b>MeanDiff, MeanDiff_pc:</b> Gain in RATE Ratio from multi-scale vs. single-scale, with '_pc' for compressed data.<br>",
424
+ "• <b>RMSE:</b> Root Mean Squared Error, measuring prediction accuracy in simulations.<br>",
425
+ "</div>"
426
+ )
427
+
428
+ chosen_metric_label <- getMetricLabel(input$metric)
429
+
430
+ if (input$compareToBest) {
431
+ c(
432
+ paste(
433
+ "This heatmap shows the improvement in",
434
+ paste0("'", chosen_metric_label, "'"),
435
+ "over the best single scale for",
436
+ input$application,
437
+ "using the", input$model, "model. The green star marks the optimal point."
438
+ ),
439
+ SharedContextText
440
+ )
441
+ } else {
442
+ c(
443
+ paste(
444
+ "This heatmap displays",
445
+ paste0("'", chosen_metric_label, "'"),
446
+ "for", input$application,
447
+ "using the", input$model,
448
+ "model across different image dimension combinations. The green star marks the optimal point."
449
+ ),
450
+ SharedContextText
451
+ )
452
+ }
453
+ })
454
+ }
455
+
456
+ # Run the Shiny App
457
+ shinyApp(ui = ui, server = server)