Spaces:
Running
Running
Update app.R
Browse files
app.R
CHANGED
@@ -1,58 +1,231 @@
|
|
|
|
|
|
1 |
library(shiny)
|
2 |
-
library(bslib)
|
3 |
library(dplyr)
|
4 |
-
library(
|
5 |
-
|
6 |
-
|
7 |
-
# Find subset of columns that are suitable for scatter plot
|
8 |
-
df_num <- df |> select(where(is.numeric), -Year)
|
9 |
-
|
10 |
-
ui <- page_sidebar(
|
11 |
-
theme = bs_theme(bootswatch = "minty"),
|
12 |
-
title = "Penguins explorer",
|
13 |
-
sidebar = sidebar(
|
14 |
-
varSelectInput("xvar", "X variable", df_num, selected = "Bill Length (mm)"),
|
15 |
-
varSelectInput("yvar", "Y variable", df_num, selected = "Bill Depth (mm)"),
|
16 |
-
checkboxGroupInput("species", "Filter by species",
|
17 |
-
choices = unique(df$Species), selected = unique(df$Species)
|
18 |
-
),
|
19 |
-
hr(), # Add a horizontal rule
|
20 |
-
checkboxInput("by_species", "Show species", TRUE),
|
21 |
-
checkboxInput("show_margins", "Show marginal plots", TRUE),
|
22 |
-
checkboxInput("smooth", "Add smoother"),
|
23 |
-
),
|
24 |
-
plotOutput("scatter")
|
25 |
-
)
|
26 |
|
27 |
-
|
28 |
-
|
29 |
-
req(input$species)
|
30 |
-
df |> filter(Species %in% input$species)
|
31 |
-
})
|
32 |
|
33 |
-
|
34 |
-
|
35 |
-
p <- ggplot(subsetted(), aes(!!input$xvar, !!input$yvar)) +
|
36 |
-
theme_light() +
|
37 |
-
list(
|
38 |
-
theme(legend.position = "bottom"),
|
39 |
-
if (input$by_species) aes(color = Species),
|
40 |
-
geom_point(),
|
41 |
-
if (input$smooth) geom_smooth()
|
42 |
-
)
|
43 |
|
44 |
-
|
45 |
-
|
46 |
-
|
47 |
-
|
48 |
-
|
49 |
-
|
50 |
-
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
51 |
|
52 |
-
|
53 |
-
|
54 |
-
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
55 |
)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
56 |
}
|
57 |
|
58 |
-
|
|
|
|
1 |
+
# setwd('~/Dropbox/ImageSeq/')
|
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")
|
|
|
|
|
|
|
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 |
+
# Define the heatMap function (unchanged except for updated default color palette)
|
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 |
+
if (openBrowser) { browser() }
|
45 |
+
s_ <- akima::interp(x = x, y = y, z = z,
|
46 |
+
xo = seq(min(x), max(x), length = N),
|
47 |
+
yo = seq(min(y), max(y), length = N),
|
48 |
+
duplicate = "mean")
|
49 |
+
if (is.null(xlim)) { xlim = range(s_$x, finite = TRUE) }
|
50 |
+
if (is.null(ylim)) { ylim = range(s_$y, finite = TRUE) }
|
51 |
+
imageFxn <- if (add.legend) fields::image.plot else graphics::image
|
52 |
+
if (!grepl(useLog, pattern = "z")) {
|
53 |
+
imageFxn(s_, xlab = xlab, ylab = ylab, log = useLog, cex.lab = cex.lab, main = main,
|
54 |
+
cex.main = cex.main, col = myCol, xlim = xlim, ylim = ylim,
|
55 |
+
legend.width = legend.width, horizontal = horizontal, yaxt = yaxt,
|
56 |
+
zlim = zlim, legend.only = legend.only)
|
57 |
+
} else {
|
58 |
+
useLog <- gsub(useLog, pattern = "z", replace = "")
|
59 |
+
zTicks <- summary(c(s_$z))
|
60 |
+
ep_ <- 0.001
|
61 |
+
zTicks[zTicks < ep_] <- ep_
|
62 |
+
zTicks <- exp(seq(log(min(zTicks)), log(max(zTicks)), length.out = 10))
|
63 |
+
zTicks <- round(zTicks, abs(min(log(zTicks, base = 10))))
|
64 |
+
s_$z[s_$z < ep_] <- ep_
|
65 |
+
imageFxn(s_$x, s_$y, log(s_$z), yaxt = yaxt,
|
66 |
+
axis.args = list(at = log(zTicks), labels = zTicks),
|
67 |
+
main = main, cex.main = cex.main, xlab = xlab, ylab = ylab,
|
68 |
+
log = useLog, cex.lab = cex.lab, xlim = xlim, ylim = ylim,
|
69 |
+
horizontal = horizontal, col = myCol, legend.width = legend.width,
|
70 |
+
zlim = zlim, legend.only = legend.only)
|
71 |
+
}
|
72 |
+
if (!is.null(vline)) { abline(v = vline, lwd = 10, col = col_vline) }
|
73 |
+
if (!is.null(hline)) { abline(h = hline, lwd = 10, col = col_hline) }
|
74 |
+
|
75 |
+
if (includeMarginals) {
|
76 |
+
points(x + rnorm(length(y), sd = marginalJitterSD_x * sd(x)),
|
77 |
+
rep(ylim[1] * 1.1, length(y)), pch = "|", col = "darkgray")
|
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",
|
89 |
+
choices = unique(sm$application),
|
90 |
+
selected = unique(sm$application)[1]),
|
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) %>%
|
118 |
+
mutate(MaxImageDimsRight = ifelse(is.na(MaxImageDimsRight),
|
119 |
+
MaxImageDimsLeft,
|
120 |
+
MaxImageDimsRight))
|
121 |
+
if (nrow(df) == 0) return(NULL)
|
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(
|
148 |
+
mean_metric = mean(as.numeric(get(input$metric)), na.rm = TRUE),
|
149 |
+
se_metric = sd(as.numeric(get(input$metric)), na.rm = TRUE) / sqrt(n()),
|
150 |
+
n = n(),
|
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)
|