diff --git a/fourier-series/DESCRIPTION b/fourier-series/DESCRIPTION new file mode 100644 index 0000000..5990844 --- /dev/null +++ b/fourier-series/DESCRIPTION @@ -0,0 +1,3 @@ +Title: Fourier Series +Description: Approximate simple functions on [0, 10], inspect their leading frequency components, and see when additional terms stop adding much reconstruction quality. +Categories: mathematics, signals, visualization diff --git a/fourier-series/app.R b/fourier-series/app.R new file mode 100644 index 0000000..b7432f6 --- /dev/null +++ b/fourier-series/app.R @@ -0,0 +1,267 @@ +# packages ---------------------------------------------------------------- +library(shiny) +library(bslib) +library(highcharter) + +# theme ------------------------------------------------------------------- +apptheme <- bs_theme() +options(highcharter.theme = hc_theme( + chart = list(style = list(fontFamily = "system-ui")), + legend = list(itemStyle = list(fontWeight = "normal")), + xAxis = list(gridLineWidth = 1), + colors = unname(bs_get_variables( + apptheme, c("primary", "danger", "success", "warning", "info", "secondary") + )), + plotOptions = list(line = list(marker = list(enabled = FALSE))) +)) + +# app options ------------------------------------------------------------- +X_MAX <- 10; K_MAX <- 20; TOP_N <- 5; N <- 400 + +target_values <- function(name, x) switch( + name, + quadratic = (x - 5)^2 / 8 - 1, + polynomial = x * (x - 5) * (x - 10) / 18, + signal = sin(2 * pi * x / 10) + + 0.6 * cos(4 * pi * x / 10) + + 0.3 * sin(8 * pi * x / 10), + floor = floor(x / 2) - 2 +) + +fourier_analysis <- function(name) { + x <- seq(0, X_MAX, length.out = N + 1) + x_fit <- x[-length(x)] + y <- target_values(name, x) + y_fit <- target_values(name, x_fit) + k <- seq_len(K_MAX) + angle_fit <- outer(x_fit, k, function(x, k) 2 * pi * k * x / X_MAX) + a <- 2 / N * colSums(y_fit * cos(angle_fit)) + b <- 2 / N * colSums(y_fit * sin(angle_fit)) + angle <- outer(x, k, function(x, k) 2 * pi * k * x / X_MAX) + parts <- sweep(cos(angle), 2, a, "*") + sweep(sin(angle), 2, b, "*") + fits <- mean(y_fit) + t(apply(parts, 1, cumsum)) + errors <- fits[-nrow(fits), , drop = FALSE] - y_fit + quality <- 100 * (1 - colSums(errors^2) / sum((y_fit - mean(y_fit))^2)) + list( + x = x, y = y, parts = parts, fits = fits, + amplitudes = sqrt(a^2 + b^2), + quality = quality, gain = c(quality[1], diff(quality)) + ) +} + +xy_data <- function(x, y) list_parse2(data.frame(x = x, y = y)) + +component_data <- function(data, selected_k) { + index <- head( + order(data$amplitudes[seq_len(selected_k)], decreasing = TRUE), TOP_N + ) + amplitudes <- data$amplitudes[index] + widths <- if (length(unique(amplitudes)) == 1) { + rep(4, length(amplitudes)) + } else { + 1.5 + 4.5 * (amplitudes - min(amplitudes)) / + (max(amplitudes) - min(amplitudes)) + } + lapply(seq_along(index), function(i) list( + name = sprintf("k = %d | A = %.3f", index[i], amplitudes[i]), + data = xy_data(data$x, data$parts[, index[i]]), + lineWidth = widths[i] + )) +} + +app_card <- function(title, id) card( + full_screen = TRUE, + card_header(title), + card_body(padding = 0, highchartOutput(id)) +) + +# ui ---------------------------------------------------------------------- +ui <- page_fillable( + theme = apptheme, + padding = 0, + layout_sidebar( + fillable = TRUE, + sidebar = bslib::sidebar( + width = 300, + title = "Fourier Series", + selectInput( + "target", tags$small("Target function"), + choices = c( + "Quadratic" = "quadratic", "Polynomial" = "polynomial", + "Periodic signal" = "signal", "Floor function" = "floor" + ), + selected = "signal" + ), + sliderInput( + "components", tags$small("Number of components"), + 1, K_MAX, 5, step = 1, width = "100%" + ), + tags$small(uiOutput("formula", inline = TRUE)), + accordion( + open = FALSE, + accordion_panel( + "How it works", + tags$small(htmltools::includeMarkdown("readme.md")) + ) + ), + tags$small(htmltools::includeMarkdown("credits.md")) + ), + layout_columns( + col_widths = c(6, 6, 6, 6), + row_heights = c(1, 1), + app_card("Function and approximation", "approximation"), + app_card("Leading Fourier components", "components_chart"), + app_card("Fourier spectrum", "spectrum"), + app_card("Reconstruction quality", "quality") + ) + ) +) + +# server ------------------------------------------------------------------ +server <- function(input, output, session) { + analysis <- reactive(fourier_analysis(input$target)) + selected <- reactive({ + data <- analysis() + k <- input$components + list( + data = data, + approximation = data$fits[, k], + components = component_data(data, k), + spectrum = data.frame(x = seq_len(k), y = data$amplitudes[seq_len(k)]), + quality = data.frame(x = seq_len(K_MAX), y = data$quality, gain = data$gain) + ) + }) + + output$formula <- renderUI({ + formulas <- c( + quadratic = "\\(f(x)=(x-5)^2/8-1\\)", + polynomial = "\\(f(x)=x(x-5)(x-10)/18\\)", + signal = "\\(f(x)=\\sin(2\\pi x/10)+0.6\\cos(4\\pi x/10)+0.3\\sin(8\\pi x/10)\\)", + floor = "\\(f(x)=\\lfloor x/2 \\rfloor-2\\)" + ) + withMathJax(HTML(formulas[[input$target]])) + }) + + output$approximation <- renderHighchart({ + view <- isolate(selected()) + highchart() |> + hc_xAxis(title = list(text = "x"), min = 0, max = X_MAX) |> + hc_yAxis(title = list(text = "f(x)")) |> + hc_tooltip(shared = TRUE, valueDecimals = 3) |> + hc_add_series( + id = "target", name = "Target", + data = xy_data(view$data$x, view$data$y), lineWidth = 4 + ) |> + hc_add_series( + id = "approximation", name = "Fourier approximation", + data = xy_data(view$data$x, view$approximation), + lineWidth = 3, dashStyle = "ShortDash" + ) + }) + + output$components_chart <- renderHighchart({ + components <- isolate(selected()$components) + chart <- highchart() |> + hc_xAxis(title = list(text = "x"), min = 0, max = X_MAX) |> + hc_yAxis(title = list(text = "Component value")) |> + hc_tooltip(shared = TRUE, valueDecimals = 3) + for (i in seq_len(TOP_N)) { + component <- components[[i]] + chart <- chart |> + hc_add_series( + id = paste0("component", i), name = component$name, + data = component$data, lineWidth = component$lineWidth + ) + } + chart + }) + + output$spectrum <- renderHighchart({ + spectrum <- isolate(selected()$spectrum) + highchart() |> + hc_chart(type = "column") |> + hc_xAxis(title = list(text = "Frequency k"), allowDecimals = FALSE) |> + hc_yAxis(title = list(text = "Amplitude")) |> + hc_tooltip(pointFormat = "Amplitude: {point.y:.3f}") |> + hc_add_series( + id = "spectrum", name = "Amplitude", + data = xy_data(spectrum$x, spectrum$y), showInLegend = FALSE + ) + }) + + output$quality <- renderHighchart({ + view <- isolate(selected()) + highchart() |> + hc_xAxis( + title = list(text = "Number of components"), + min = 1, max = K_MAX, allowDecimals = FALSE + ) |> + hc_yAxis( + title = list(text = "Reconstruction quality"), + min = 0, max = 100, labels = list(format = "{value}%") + ) |> + hc_tooltip(pointFormatter = JS( + "function () { + return '' + Highcharts.numberFormat(this.y, 2) + + '%
Gain: +' + + Highcharts.numberFormat(this.gain, 2) + ' pp'; + }" + )) |> + hc_add_series( + id = "quality_curve", name = "Quality", + data = list_parse2(view$quality), lineWidth = 4 + ) |> + hc_add_series( + id = "selected_k", name = "Selected", type = "scatter", + data = list(list( + x = input$components, y = view$data$quality[input$components] + )), + marker = list(radius = 7), showInLegend = FALSE + ) + }) + + observeEvent(selected(), { + view <- selected() + highchartProxy("approximation") |> + hcpxy_update_series( + id = "target", data = xy_data(view$data$x, view$data$y) + ) |> + hcpxy_update_series( + id = "approximation", data = xy_data(view$data$x, view$approximation) + ) + + proxy <- highchartProxy("components_chart") + for (i in seq_len(TOP_N)) { + if (i <= length(view$components)) { + component <- view$components[[i]] + proxy <- proxy |> + hcpxy_update_series( + id = paste0("component", i), name = component$name, + data = component$data, lineWidth = component$lineWidth, + visible = TRUE, showInLegend = TRUE + ) + } else { + proxy <- proxy |> + hcpxy_update_series( + id = paste0("component", i), data = list(), + visible = FALSE, showInLegend = FALSE + ) + } + } + + highchartProxy("spectrum") |> + hcpxy_update_series( + id = "spectrum", data = xy_data(view$spectrum$x, view$spectrum$y) + ) + highchartProxy("quality") |> + hcpxy_update_series(id = "quality_curve", data = list_parse2(view$quality)) |> + hcpxy_update_series( + id = "selected_k", + data = list(list( + x = input$components, y = view$data$quality[input$components] + )) + ) + }, ignoreInit = TRUE) +} + +shinyApp(ui, server) diff --git a/fourier-series/credits.md b/fourier-series/credits.md new file mode 100644 index 0000000..d2e18a3 --- /dev/null +++ b/fourier-series/credits.md @@ -0,0 +1 @@ +App made by [Joshua Kunst](https://jkunst.com) with ❤️ and ☕ using Shiny for R ✨. Code [here](https://github.com/jbkunst/visual-data-lab). diff --git a/fourier-series/readme.md b/fourier-series/readme.md new file mode 100644 index 0000000..c4635cb --- /dev/null +++ b/fourier-series/readme.md @@ -0,0 +1,12 @@ +A Fourier series represents a function as a weighted sum of sine and cosine waves. + +Choose a target function on the interval **0 to 10** and change the number of components used in its reconstruction. + +- **Function and approximation** compares the target with the current Fourier reconstruction. +- **Leading Fourier components** shows up to five of the strongest waves on the same axis. Line width increases with component amplitude. +- **Fourier spectrum** summarizes the amplitude associated with every included frequency. +- **Reconstruction quality** shows how much variation is recovered as components are added. The tooltip also reports the marginal gain from the latest component. + +The periodic signal is built from only three frequencies, so it can be reconstructed exactly with a few terms. The floor function contains jumps and therefore needs many higher frequencies. Oscillations near a jump are expected and illustrate the Gibbs phenomenon. + +Fourier series repeat the selected interval periodically. When the function does not join smoothly at the two boundaries, the periodic extension creates an additional discontinuity.