Spaces:
Running
Running
Create warmup/app_v1.R
Browse files- 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)
|