diff --git a/README.Rmd b/README.Rmd index 2c3f0b7..e1b63c4 100644 --- a/README.Rmd +++ b/README.Rmd @@ -29,7 +29,23 @@ are publicly available 3d scans of the Hamby-Brundage bullet set #44 provided by Download: - [Known Bullets 1 and 2 from Barrel 1](examples/Hamby-44/barrel 1.zip) - - Questioned bullets: Bullet [E](examples/Hamby-44/Questioned/Bullet E.zip), [F](examples/Hamby-44/Questioned/Bullet F.zip), - [G](examples/Hamby-44/Questioned/Bullet G.zip), - - + - Questioned bullets: [E](examples/Hamby-44/Questioned//Bullet E.zip), + [F](examples/Hamby-44/Questioned//Bullet F.zip), +[G](examples/Hamby-44/Questioned//Bullet G.zip), +[H](examples/Hamby-44/Questioned//Bullet H.zip), +[I](examples/Hamby-44/Questioned//Bullet I.zip), +[J](examples/Hamby-44/Questioned//Bullet J.zip), +[K](examples/Hamby-44/Questioned//Bullet K.zip), +[L](examples/Hamby-44/Questioned//Bullet L.zip), +[O](examples/Hamby-44/Questioned//Bullet O.zip), +[P](examples/Hamby-44/Questioned//Bullet P.zip), +[S](examples/Hamby-44/Questioned//Bullet S.zip), +[T](examples/Hamby-44/Questioned//Bullet T.zip), +[U](examples/Hamby-44/Questioned//Bullet U.zip), +[X](examples/Hamby-44/Questioned//Bullet X.zip), +[Y](examples/Hamby-44/Questioned//Bullet Y.zip) + + +## Start the Analyzr + +Click on the link to start the app: [BulletAnalyzr](https://labs.omnianalytics.org/bullet-analyzer/) \ No newline at end of file diff --git a/README.md b/README.md index ec9052c..5ee90a8 100644 --- a/README.md +++ b/README.md @@ -19,7 +19,19 @@ Download: - [Known Bullets 1 and 2 from Barrel 1](examples/Hamby-44/barrel%201.zip) -- Questioned bullets: Bullet - [E](examples/Hamby-44/Questioned/Bullet%20E.zip), - [F](examples/Hamby-44/Questioned/Bullet%20F.zip), - [G](examples/Hamby-44/Questioned/Bullet%20G.zip), +- Questioned bullets: [E](examples/Hamby-44/Questioned//Bullet%20E.zip), + [F](examples/Hamby-44/Questioned//Bullet%20F.zip), + [G](examples/Hamby-44/Questioned//Bullet%20G.zip), + [H](examples/Hamby-44/Questioned//Bullet%20H.zip), + [I](examples/Hamby-44/Questioned//Bullet%20I.zip), + [J](examples/Hamby-44/Questioned//Bullet%20J.zip), + [K](examples/Hamby-44/Questioned//Bullet%20K.zip), + [L](examples/Hamby-44/Questioned//Bullet%20L.zip), + [O](examples/Hamby-44/Questioned//Bullet%20O.zip), + [P](examples/Hamby-44/Questioned//Bullet%20P.zip), + [S](examples/Hamby-44/Questioned//Bullet%20S.zip), + [T](examples/Hamby-44/Questioned//Bullet%20T.zip), + [U](examples/Hamby-44/Questioned//Bullet%20U.zip), + [X](examples/Hamby-44/Questioned//Bullet%20X.zip), + [Y](examples/Hamby-44/Questioned//Bullet%20Y.zip) + diff --git a/app/.Rapp.history b/app/.Rapp.history new file mode 100644 index 0000000..b39707e --- /dev/null +++ b/app/.Rapp.history @@ -0,0 +1,2 @@ +setwd("~/Desktop/csafe/bullet/bulletanalyzer") +shiny::runApp() diff --git a/app/Dump/appold.R b/app/Dump/appold.R new file mode 100755 index 0000000..729513a --- /dev/null +++ b/app/Dump/appold.R @@ -0,0 +1,894 @@ +## Load Libraries +library(shiny) +library(shinythemes) +library(shinyjs) +library(shinyBS) +library(shinycssloaders) +library(plotly) +library(dplyr) +library(tidyr) +library(bulletr) +library(ggplot2) +library(gridExtra) +library(randomForest) + +options(shiny.maxRequestSize = 30*1024^2) + +## Data Resources +bullet_choices <- file.path("data", "bullets", dir("data/bullets")) +names(bullet_choices) <- basename(bullet_choices) +addResourcePath("images", "images") + +## UI +ui <- fluidPage(title = "BulletAnalyzr", + useShinyjs(), + + tags$head( + tags$link( + href = "https://fonts.googleapis.com/css?family=Montserrat:400,500,700,900|Ubuntu:400,500,700", + rel = "stylesheet", + type = "text/css" + ), + tags$link(rel = "shortcut icon", href = "favicon.png", type = "image/png"), + tags$link(rel = "icon", href = "favicon.png", type = "image/png") + ), + includeCSS("css/styles.css"), + + # Use tags$script to include custom JavaScript + tags$head( + tags$script( + HTML(" + $(document).on('click', '#printBtn', function() { + window.print(); + }); + ") + ) + ), + + tags$div(id="app-container", + fluidRow( + column(width = 4,tags$a(target = "_blank", href="https://forensicstats.org", tags$img(src = "images/BulletAnalzr-Mark-2.png", width="500px"))), + column(width = 4,br()), + column(width = 4,tags$a(target = "_blank", href="https://forensicstats.org", tags$img(src = "images/BulletAnalyzr-Design-2.png", width="500px")),align="right"), + ), + tags$div(id="main-content", + navbarPage(title = NULL,#div(div(id = "img-id",img(src = "csafe_tools_blue.png")),NULL), + tabPanel("Home", + sidebarLayout( + tags$div(id="my-sidebar", sidebarPanel( + # tags$h1(class = "responsive-text", "BULLETANALYZER"), + # br(), + # tags$head(tags$style("#info{font-size: 18px;}")), + + hidden(checkboxInput("stage0", "Stage 0")), + hidden(checkboxInput("stage1", "Stage 1")), + hidden(checkboxInput("stage2", "Stage 2")), + hidden(checkboxInput("stage3", "Stage 3")), + hidden(checkboxInput("stage4", "Stage 4")), + hidden(checkboxInput("stage5", "Stage 5")), + hidden(checkboxInput("stage6", "Stage 6")), + + hidden(checkboxInput("stage00", "Stage 0")), + hidden(checkboxInput("stage11", "Stage 1")), + hidden(checkboxInput("stage22", "Stage 2")), + hidden(checkboxInput("stage33", "Stage 3")), + hidden(checkboxInput("stage44", "Stage 4")), + hidden(checkboxInput("stage55", "Stage 5")), + hidden(checkboxInput("stage66", "Stage 6")), + + shinyjs::hidden( + div(id = "stepstep", + h4("Step-By-Step Procedure"), + helpText("Press the following button to begin the step-by-step version of the algorithm, where each parameter can be tweaked according to your liking."), + actionButton("confirm_stepstep", "Begin Step-By-Step", icon = icon("check")) + ), + + hr() + ), + + div(id = "autonomous", + tags$h1(class = "responsive-text","GET STARTED"), + br(), + helpText("Press the following button to automatically use all the default parameters to get a similarity value for two bullet lands."), + br(), + actionButton("confirm_autonomous", "Begin")#, icon = icon("check")) + ), + + shinyjs::hidden( + div(id = "landselect", + conditionalPanel(condition = "!input.stage0 || input.stage5", + br(), + + h4("Stage 1 Options"), + + selectInput("choose1", "Choose First Land", choices = c("Upload Image", bullet_choices), selected = bullet_choices[5]), + + conditionalPanel(condition = "input.choose1 == 'Upload Image'", + fileInput("file1", "First Bullet Land") + ), + + selectInput("choose2", "Choose Second Land", choices = c("Upload Image", bullet_choices), selected = bullet_choices[7]), + + conditionalPanel(condition = "input.choose2 == 'Upload Image'", + fileInput("file2", "Second Bullet Land") + ), + + actionButton("confirm0", "Generate Report")#, icon = icon("check")), + + # hr() + ) + ) + ), + + conditionalPanel(condition = "input.stage5", hr()), + + conditionalPanel(condition = "input.stage0 && !input.stage1 || input.stage5", + h4("Stage 2 Options"), + + hr(), + + sliderInput("xcoord1", "X Coordinate (First Land)", min = 1, max = 251, value = 136, step = 1), + sliderInput("xcoord2", "X Coordinate (Second Land)", min = 252, max = 502, value = 386, step = 1), + + hr(), + + actionButton("confirm", "Confirm Coordinates", icon = icon("check")), + + # hr(), + + # actionButton("back", "Back to Stage 1", icon = icon("backward")) + ), + + conditionalPanel(condition = "input.stage5", hr()), + + conditionalPanel(condition = "input.stage1 && !input.stage2 || input.stage5", + h4("Stage 3 Options"), + + hr(), + + sliderInput("bounds1", "Coordinate Bounds 1", min = 0, max = 2400, value = c(0, 2400)), + sliderInput("bounds2", "Coordinate Bounds 2", min = 0, max = 2400, value = c(0, 2400)), + + hr(), + + actionButton("confirm2", "Confirm Bounds", icon = icon("check")), + + # hr(), + + # actionButton("back2", "Back to Stage 2", icon = icon("backward")) + ), + + conditionalPanel(condition = "input.stage5", hr()), + + conditionalPanel(condition = "input.stage2 && !input.stage3 || input.stage5", + h4("Stage 4 Options"), + + hr(), + + sliderInput("span", "Loess Span", min = 0.01, max = 0.99, value = 0.03, step = 0.01), + + hr(), + + actionButton("confirm3", "Confirm Span", icon = icon("check")), + + # hr(), + + # actionButton("back3", "Back to Stage 3", icon = icon("backward")) + ), + + conditionalPanel(condition = "input.stage5", hr()), + + conditionalPanel(condition = "input.stage3 && !input.stage4 || input.stage5", + h4("Stage 5 Options"), + + hr(), + + numericInput("alignment", "Alignment", min = -1000, max = 1000, step = 1.5625, value = 0), + + hr(), + + actionButton("confirm4", "Confirm Alignment", icon = icon("check")), + + # hr(), + + # actionButton("back4", "Back to Stage 4", icon = icon("backward")) + ), + + conditionalPanel(condition = "input.stage4", + h4("Stage 6 Options"), + + hr(), + + sliderInput("smoothfactor", "Smoothing Factor", min = 1, max = 100, value = 35, step = 1), + + hr(), + + actionButton("confirm5", "Confirm Smoothing", icon = icon("check")), + + # hr(), + + #actionButton("back5", "Back to Stage 5", icon = icon("backward")) + ), + + conditionalPanel(condition = "input.stage5", + h4("Stage 7 Options"), + + hr(), + + actionButton("confirm6", "Confirm Features", icon = icon("check")), + + # hr(), + + # actionButton("back6", "Back to Stage 6", icon = icon("backward")) + ), + + hidden( + h4("Lighting Options"), + sliderInput("subsample", "Subsample Factor", min = 1, max = 20, value = 2), + sliderInput("ambient_lighting", "Ambient Lighting", min = 0, max = 1, step = 0.1, value = 0.8), + sliderInput("diffuse_lighting", "Diffuse Lighting", min = 0, max = 1, step = 0.1, value = 0.8), + sliderInput("specular_lighting", "Specular Lighting", min = 0, max = 2, step = 0.05, value = 0.05), + sliderInput("roughness_lighting", "Roughness Lighting", min = 0, max = 1, step = 0.1, value = 0.5), + sliderInput("fresnel_lighting", "Fresnel Lighting", min = 0, max = 5, step = 0.1, value = 0.2) + ), + + br(), + conditionalPanel(condition = "input.stage5", + h4("RESULTS EXPORT"), + helpText("Press the following button to export the given results to a PDF file, or print the results."), + actionButton("printBtn", "Print / Save to PDF") + ) + )), + + mainPanel( + conditionalPanel(condition = "input.stage5", + div(class = "center-container", + div(class = "rounded-box", + div(style = "text-align: center; color: #9E1A97; font-size: 32px; font-weight: 700; font-family: 'Montserrat', sans-serif;", "RESULTS:"), + div(style = "text-align: center;", h4(uiOutput("rfpred"))) + ) + ), + + hr(), + + h3("Features"), + hr(), + HTML("Here are the values of the features computed on the aligned bullet signatures."), + + DT::dataTableOutput("features"), + + hr(), + + actionButton("restart", "Restart Algorithm", icon = icon("refresh")), + + hr() + ), + conditionalPanel(condition = "input.stage0 && !input.stage1 || input.stage5", + h3("Stage 2: Finding a Stable Region"), + hr(), + HTML("Below you will find surface topologies of the two bullet lands you have uploaded. You can rotate, pan, zoom, and perform a number of other functions to examine the surfaces.

Our goal is to find a stable region. We want an area of the bullet where there is minimal noise or tank rash, but plenty of pronounced striation markings.

We step through cross-sections of each land at a fixed step size, and uses the CCF (cross-correlation function) to determine stability (a high CCF means that subsequent cross-sections are similar to each other). We begin this procedure near the area where striation markings are typically most pronounced.

We have automatically identified what is believed to be a stable region. You may choose the location to take a cross-section if the algorithm's choice is not satisfactory.") + ), + conditionalPanel(condition = "input.stage1 && !input.stage2 || input.stage5", + h3("Stage 3: Removing Grooves"), + hr(), + HTML("The cross-sections you have taken are shown below. Our next goal will be to remove the grooves, which contain no relevant information for matching, and greatly exceed the size of a typical striation mark. The more accurate we are with groove detection, the less noise we introduce to the remaining steps.

We use a double-pass smoothing method to determine the location of the grooves. We have again attempted to locate the grooves for you, but you may define them yourself. As you adjust the sliders, the plot will automatically update."), + hr(), + + withSpinner(plotOutput("crosssection")) + ), + conditionalPanel(condition = "input.stage2 && !input.stage3 || input.stage5", + h3("Stage 4: Removing Global Structure"), + hr(), + HTML("We have removed the grooves, but the global structure of the cross-section still dominates the overall appearance, making striae more difficult to locate. At this point we are going to fit a loess regression to model this structure. The loess regression includes a span parameter which adjusts the amount of smoothing used. Different values will yield different output. We default to a span of 0.03, but this may be adjusted as desired. "), + hr(), + + withSpinner(plotOutput("loess1")), + withSpinner(plotOutput("loess2")) + ), + conditionalPanel(condition = "input.stage3 && !input.stage4 || input.stage5", + h3("Stage 5: Aligning Signatures"), + hr(), + HTML("The residuals from the loess fit we have extracted in the previous stage are called the bullet signatures. They will form the basis for the rest of the analysis. Since scans are not always taken at a fixed location, and the rotation of the bullet may be slightly less than ideal, the signatures may not automatically `align` in their respective coordinate spaces.

Because the signatures are defined by the residuals, the peaks and valleys visible in this plot represent the striation markings we are looking for. In order to make matching easier, our next step is to align the two signatures.

The alignment parameter defines a horizontal offset that will shift the green graph to the right. The objective is to create perfect alignment between the graphs so that the correlation between the two will be maximized. We suggest an optimal alignment, but it can be adjusted if necessary."), + + plotOutput("alignment") + ), + conditionalPanel(condition = "input.stage4", + h3("Stage 6: Peaks and Valleys"), + hr(), + HTML("With aligned signatures, we now turn our attention to determining what constitutes a peak or a valley. Since there is a lot of noise, this step involves one more smoothing pass. The amount of smoothing reduces the possibility of noisy detections of peaks and valleys in the signature, but too much smoothing can smooth over some real features of the signature.

We can specify a smoothing window, called the smoothing factor, as the number of neighbors to include in the window. For instance, a value of 16 would mean that the nearest 16 points, spanning 16 * 1.5625 = 25 micrometers, would be included."), + + withSpinner(plotOutput("peaks1")), + withSpinner(plotOutput("peaks2")) + ), + #conditionalPanel(condition = "input.stage5", + # h3("Stage 6: Extract Features"), + # hr(), + # HTML("We now have smoothed, aligned bullet signatures with associated peaks and valleys. This gives us a number of features we can extract.

At this point, there is really nothing left to configure about the algorithm. The features extracted are displayed below. The definitions of each can be found in Hare 2016. Press Confirm Features when you are ready to get your predicted probability of a match.")), + # + # dataTableOutput("features") + #), + + + h3("WELCOME TO BULLETANALYZR!"), + p("Our innovation combines 3D imagery and sophisticated algorithms to revolutionize bullet analysis. This prototype demonstrates how our methods can calculate the likelihood of the observed similarity if two bullets originated from the same firearm versus different firearms. It's a work in progress, evolving through feedback from diverse communities."), + br(), + h4("BULLET LAND SURFACES",align="center"), + withSpinner(plotlyOutput("trendPlot", height = "700px")), + hr() + ) + )), + tabPanel( + "About", + h4(HTML("CSAFE Tools is a software suite of state-of-the-art statistical libraries designed to assist practitioners in analyzing forensic data. This work was developed in collaboration with the Center for Statistics and Applications in Forensic Evidence (CSAFE) at Iowa State University and Omni Analytics Group. These procedures are fully open-source and transparent. For more details on the underlying code, please see the GitHub repository for the companion R package.")), + br(), br(), + h4(HTML("This software is an implementation of a front-end to the bulletr package.")), + h4(HTML("This application will walk through the steps used to programmatically determine the probability that two bullets were fired from the same gun. During discharge, as a bullet travels out of the chamber, it is imprinted with a groove signature that is unique to that gun’s barrel. The grooved pattern of a gun’s barrel is so distinct that the striations that are imprinted on a set of fired bullet need only be matched across a small region for there to be statistical confidence of a match; therefore probabilistic comparisons can be made at the bullet land level which represent only one-sixth of a bullet.

+ Hare, E., Hofmann, H., and Carriquiry, A., Algorithmic Approaches to Match Degraded Land Impressions. Law, Probability and Risk, mgx018, https://doi.org/10.1093/lpr/mgx018
+ Hare, E., Hofmann, H., and Carriquiry, A., Automatic Matching of Bullet Land Impressions. Annals of Applied Statistics. doi: 10.1214/17-AOAS1080" + )), + hr() + ), + tabPanel("Instructions",), + tabPanel("Contact",) + ))), + # Footer + tags$div(id="global-footer", + fluidRow( + column(width = 4,tags$img(src="csafe_tools_blue.png", alt="Logo", height = "60px")), + column(width = 4,tags$p("195 Durham Center, 613 Morrill Road, Ames, Iowa, 50011")), + column(width = 4,tags$p("(C) 2023 | All Rights Reserved", class="right-float")) + ) + ) +) + +server <- function(input, output, session) { + # showModal(modalDialog( + # title = "Welcome to BulletAnalyzr! ", + # " Our innovation combines 3D imagery and sophisticated algorithms to revolutionize bullet analysis. This prototype demonstrates how our methods can calculate the likelihood of the observed similarity if two bullets originated from the same firearm versus different firearms. It's a work in progress, evolving through feedback from diverse communities. Click 'Get Started' on the next screen to explore this prototype further.", + # easyClose = TRUE, + # footer = modalButton("Ok") + # )) + + bullet1 <- reactive({ + withProgress(message = "Loading bullet data...", expr = { + if (input$choose1 == "Upload Image") { + if (is.null(input$file1)) return(NULL) + + return(read_x3p(input$file1$datapath)) + } + + return(read_x3p(input$choose1)) + }) + }) + + bullet2 <- reactive({ + withProgress(message = "Loading bullet data...", expr = { + if (input$choose2 == "Upload Image") { + if (is.null(input$file2)) return(NULL) + + return(read_x3p(input$file2$datapath)) + } + + cat(input$file2) + + return(read_x3p(input$choose2)) + }) + }) + + values <- reactiveValues(app_type = "stepstep") + + observeEvent(input$confirm_autonomous, { + values$app_type <- "autonomous" + + shinyjs::hide("stepstep") + shinyjs::hide("confirm_autonomous") + shinyjs::show("landselect") + shinyjs::hide("prelim") + shinyjs::show("land") + }) + + observeEvent(input$confirm_stepstep, { + values$app_type <- "stepstep" + + shinyjs::hide("autonomous") + shinyjs::hide("confirm_stepstep") + shinyjs::show("landselect") + shinyjs::hide("prelim") + shinyjs::show("land") + }) + + observeEvent(input$confirm0, { + shinyjs::hide("autonomous") + shinyjs::hide("stepstep") + + if (!is.null(bullet1()) && !is.null(bullet2())) { + updateCheckboxInput(session, "stage0", value = TRUE) + if (values$app_type == "autonomous") { + updateCheckboxInput(session, "stage00", value = TRUE) + } + } + }) + + observeEvent(input$stage00, { + if (input$confirm0 && input$stage00) { + updateCheckboxInput(session, "stage1", value = TRUE) + updateCheckboxInput(session, "stage11", value = TRUE) + } + }, priority = -1) + + observeEvent(input$stage11, { + if (input$confirm0 && input$stage11 && values$app_type == "autonomous") { + updateCheckboxInput(session, "stage2", value = TRUE) + updateCheckboxInput(session, "stage22", value = TRUE) + } + }, priority = -1) + + observeEvent(input$stage22, { + if (input$confirm0 && input$stage22 && values$app_type == "autonomous") { + updateCheckboxInput(session, "stage3", value = TRUE) + updateCheckboxInput(session, "stage33", value = TRUE) + } + }, priority = -1) + + observeEvent(input$stage33, { + if (input$confirm0 && input$stage33 && values$app_type == "autonomous") { + updateCheckboxInput(session, "stage4", value = TRUE) + updateCheckboxInput(session, "stage44", value = TRUE) + } + }, priority = -1) + + observeEvent(input$stage44, { + if (input$confirm0 && input$stage44 && values$app_type == "autonomous") { + updateCheckboxInput(session, "stage5", value = TRUE) + updateCheckboxInput(session, "stage55", value = TRUE) + } + }, priority = -1) + + observeEvent(input$stage55, { + if (input$confirm0 && input$stage55 && values$app_type == "autonomous") { + updateCheckboxInput(session, "stage6", value = TRUE) + updateCheckboxInput(session, "stage66", value = TRUE) + } + }, priority = -1) + + theSurface <- reactive({ + if (is.null(bullet1()) || is.null(bullet2())) return(NULL) + + b1 <- bullet1() + b2 <- bullet2() + + surf.b1 <- b1[[2]] + surf.b2 <- b2[[2]] + + minrows <- min(nrow(surf.b1), nrow(surf.b2)) + + surf.mat <- cbind(surf.b1[1:minrows,], surf.b2[1:minrows,]) + + x_idx <- seq(1, nrow(surf.mat), by = 2) + y_idx <- seq(1, ncol(surf.mat), by = 2) + + return(surf.mat[x_idx, y_idx]) + }) + + observe({ + updateSliderInput(session, "xcoord1", max = ncol(theSurface()) / 2, value = ncol(theSurface()) / 4) + updateSliderInput(session, "xcoord2", max = ncol(theSurface()), min = 1 + ncol(theSurface()) / 2, value = ncol(theSurface()) * 3 / 4) + }) + + output$trendPlot <- renderPlotly({ + if (is.null(theSurface())) return(NULL) + + p <- plot_ly(z = theSurface(), type = "surface", showscale = FALSE, lighting = list(ambient = input$ambient_lighting, + diffuse = input$diffuse_lighting, + specular = input$specular_lighting, + roughness = input$roughness_lighting, + fresnel = input$fresnel_lighting)) + p + }) + + observeEvent(input$stage0, { + if (!is.null(theSurface()) && input$stage0) { + withProgress(message = "Calculating CCF...", expr = { + crosscut1 <- bulletCheckCrossCut("", + bullet = bullet1(), + xlimits = seq(25, 500, by = 25)) + + crosscut2 <- bulletCheckCrossCut("", + bullet = bullet2(), + xlimits = seq(25, 500, by = 25)) + + updateSliderInput(session, "xcoord1", value = crosscut1) + updateSliderInput(session, "xcoord2", value = crosscut2 + ncol(theSurface()) / 2) + }) + } + }) + + observeEvent(input$confirm, { + updateCheckboxInput(session, "stage1", value = TRUE) + }) + + observeEvent(input$back, { + updateCheckboxInput(session, "stage0", value = FALSE) + }) + + fortified1 <- reactive({ + if (is.null(bullet1()) || !input$stage1) return(NULL) + + bul <- bullet1() + bul[[3]] <- "b1" + names(bul)[3] <- "path" + + return(fortify_x3p(bul)) + }) + + fortified2 <- reactive({ + if (is.null(bullet2()) || !input$stage1) return(NULL) + + bul <- bullet2() + bul[[3]] <- "b2" + names(bul)[3] <- "path" + + return(fortify_x3p(bul)) + }) + + crosscut1 <- reactive({ + if (is.null(bullet1()) || !input$stage1) return(NULL) + + return(get_crosscut(bullet = bullet1(), x = input$xcoord1)) + }) + + crosscut2 <- reactive({ + if (is.null(bullet2()) || !input$stage1) return(NULL) + + return(get_crosscut(bullet = bullet2(), x = input$xcoord2 - ncol(theSurface()) / 2)) + }) + + observe({ + if (!is.null(fortified1()) && !is.null(fortified2())) { + updateSliderInput(session, "bounds1", max = floor(max(fortified1()$y)), value = c(0, floor(max(fortified1()$y)))) + updateSliderInput(session, "bounds2", max = floor(max(fortified2()$y)), value = c(0, floor(max(fortified2()$y)))) + } + }) + + observeEvent(input$stage1, { + if (!is.null(crosscut1()) && !is.null(crosscut2())) { + + withProgress(message = "Locating grooves...", expr = { + groove1 <- get_grooves(crosscut1()) + groove2 <- get_grooves(crosscut2()) + + updateSliderInput(session, "bounds1", value = groove1$groove) + updateSliderInput(session, "bounds2", value = groove2$groove) + }) + } + }) + + output$crosssection <- renderPlot({ + if (is.null(fortified1()) || is.null(fortified2())) return(NULL) + + fortified <- fortified1() + fortified2 <- fortified2() + + myx <- unique(fortified$x) + xval <- myx[which.min(abs(myx - input$xcoord1))] + myx2 <- unique(fortified2$x) + xval2 <- myx2[which.min(abs(myx2 - (input$xcoord2 - ncol(theSurface()) / 2)))] + + plotdat <- fortified %>% + filter(x == xval) %>% + select(-x) %>% + full_join( + fortified2 %>% + filter(x == xval2) %>% + select(-x) + , by = c("y" = "y")) %>% + rename(bullet1 = value.x, bullet2 = value.y) %>% + gather(key = bullet, value = value, bullet1:bullet2) + + plotdat$include <- FALSE + plotdat$include[plotdat$bullet == "bullet1"] <- (plotdat$y[plotdat$bullet == "bullet1"] >= input$bounds1[1] & plotdat$y[plotdat$bullet == "bullet1"] <= input$bounds1[2]) + plotdat$include[plotdat$bullet == "bullet2"] <- (plotdat$y[plotdat$bullet == "bullet2"] >= input$bounds2[1] & plotdat$y[plotdat$bullet == "bullet2"] <= input$bounds2[2]) + + vline.data <- data.frame(zleft = c(input$bounds1[1], input$bounds2[1]), + zright = c(input$bounds1[2], input$bounds2[2]), + bullet = c("bullet1", "bullet2")) + + ggplot(data = plotdat, aes(x = y, y = value, alpha = include)) + + facet_wrap(~bullet, nrow = 2) + + geom_vline(aes(xintercept = zleft), colour = "blue", data = vline.data) + + geom_vline(aes(xintercept = zright), colour = "blue", data = vline.data) + + geom_line(linewidth = 1) + + xlim(c(0, max(plotdat$y))) + + theme_bw() + }) + + observeEvent(input$confirm2, { + updateCheckboxInput(session, "stage2", value = TRUE) + }) + + observeEvent(input$back2, { + updateCheckboxInput(session, "stage1", value = FALSE) + }) + + loess1 <- reactive({ + if (is.null(crosscut1()) || !input$stage2) return(NULL) + + return(fit_loess(bullet = crosscut1(), groove = list(groove = input$bounds1), span = input$span)) + }) + + loess2 <- reactive({ + if (is.null(crosscut2()) || !input$stage2) return(NULL) + + return(fit_loess(bullet = crosscut2(), groove = list(groove = input$bounds2), span = input$span)) + }) + + processed1 <- reactive({ + if (is.null(fortified1()) || !input$stage2) return(NULL) + + myx <- unique(fortified1()$x) + xval <- myx[which.min(abs(myx - input$xcoord1))] + + processBullets(bullet = bullet1(), name = "b1", x = xval, grooves = input$bounds1) + }) + + processed2 <- reactive({ + if (is.null(fortified2()) || !input$stage2) return(NULL) + + myx <- unique(fortified2()$x) + xval <- myx[which.min(abs(myx - (input$xcoord2 - ncol(theSurface()) / 2)))] + + processBullets(bullet = bullet2(), name = "b2", x = xval, grooves = input$bounds2) + }) + + smoothed <- reactive({ + if (is.null(processed1()) || is.null(processed2())) return(NULL) + + bullets_processed <- list(b1 = processed1(), b2 = processed2()) + + result <- bullets_processed %>% bind_rows %>% bulletSmooth(span = input$span) + result$bullet <- c(rep("b1", nrow(processed1())), rep("b2", nrow(processed2()))) + + return(result) + }) + + output$loess1 <- renderPlot({ + if (is.null(loess1()) || is.null(smoothed())) return(NULL) + + withProgress(message = "Loading plots...", { + p1 <- ggplot(data = filter(smoothed(), bullet == "b1"), aes(x = y, y = l30)) + + geom_line() + + theme_bw() + + grid.arrange(loess1()$fitted, p1, ncol = 2) + }) + }) + + output$loess2 <- renderPlot({ + if (is.null(loess2()) || is.null(smoothed())) return(NULL) + + withProgress(message = "Loading plots...", { + p2 <- ggplot(data = filter(smoothed(), bullet == "b2"), aes(x = y, y = l30)) + + geom_line() + + theme_bw() + + grid.arrange(loess2()$fitted, p2, ncol = 2) + }) + }) + + observeEvent(input$confirm3, { + updateCheckboxInput(session, "stage3", value = TRUE) + }) + + observeEvent(input$back3, { + updateCheckboxInput(session, "stage2", value = FALSE) + }) + + myalign <- reactive({ + if (is.null(smoothed())) return(NULL) + + bulletAlign(data = smoothed()) + }) + + observeEvent(input$stage3, { + if (!is.null(myalign())) { + withProgress(message = "Determining alignment...", expr = { + updateSliderInput(session, "alignment", value = myalign()$lag) + }) + } + }) + + chosenalign <- reactive({ + if (is.null(myalign())) return(NULL) + + alignval <- round(input$alignment / 1.5625, digits = 0) * 1.5625 + + chosen <- myalign() + chosen$lag <- alignval + chosen$bullets$y[chosen$bullets$bullet == "b2"] <- chosen$bullets$y[chosen$bullets$bullet == "b2"] - min(chosen$bullets$y[chosen$bullets$bullet == "b2"]) + chosen$lag + + return(chosen) + }) + + output$alignment <- renderPlot({ + if (is.null(chosenalign())) return(NULL) + + mydat <- chosenalign()$bullets + + ggplot(data = mydat, aes(x = y, y = l30, colour = bullet, alpha = I(0.8))) + + geom_line() + + theme(legend.position = "bottom") + + theme_bw() + }) + + observeEvent(input$confirm4, { + updateCheckboxInput(session, "stage4", value = TRUE) + }) + + observeEvent(input$back4, { + updateCheckboxInput(session, "stage3", value = FALSE) + }) + + peaks1 <- reactive({ + if (is.null(chosenalign()) || !input$stage4) return(NULL) + + bAlign <- chosenalign() + lofX <- bAlign$bullet + + return(get_peaks(subset(lofX, bullet == "b1"), smoothfactor = input$smoothfactor)) + }) + + peaks2 <- reactive({ + if (is.null(chosenalign()) || !input$stage4) return(NULL) + + bAlign <- chosenalign() + lofX <- bAlign$bullet + + return(get_peaks(subset(lofX, bullet == "b2"), smoothfactor = input$smoothfactor)) + }) + + output$peaks1 <- renderPlot({ + if (is.null(peaks1())) return(NULL) + + return(peaks1()$plot) + }) + + output$peaks2 <- renderPlot({ + if (is.null(peaks2())) return(NULL) + + return(peaks2()$plot) + }) + + CMS <- reactive({ + if (is.null(peaks1()) || is.null(peaks2())) return(NULL) + + bAlign <- chosenalign() + lofX <- bAlign$bullet + + peaks1 <- peaks1() + peaks2 <- peaks2() + + peaks1$lines$bullet <- "b1" + peaks2$lines$bullet <- "b2" + + lines <- striation_identify(peaks1$lines, peaks2$lines) + maxCMS <- maxCMS(lines$match == TRUE) + list(maxCMS = maxCMS, ccf = bAlign$ccf, lag = bAlign$lag, + lines = lines, bullets = lofX) + }) + + features <- reactive({ + if (is.null(CMS())) return(NULL) + + res <- CMS() + + lofX <- res$bullets + aligned <- chosenalign() + b12 <- unique(lofX$bullet) + + subLOFx1 <- subset(aligned$bullets, bullet==b12[1]) + subLOFx2 <- subset(aligned$bullets, bullet==b12[2]) + + ys <- intersect(subLOFx1$y, subLOFx2$y) + idx1 <- which(subLOFx1$y %in% ys) + idx2 <- which(subLOFx2$y %in% ys) + distr.dist <- mean((subLOFx1$val[idx1] - subLOFx2$val[idx2])^2, na.rm=TRUE) + distr.sd <- sd(subLOFx1$val, na.rm=TRUE) + sd(subLOFx2$val, na.rm=TRUE) + km <- which(res$lines$match) + knm <- which(!res$lines$match) + if (length(km) == 0) km <- c(length(knm)+1,0) + if (length(knm) == 0) knm <- c(length(km)+1,0) + # browser() + # feature extraction + + signature.length <- min(nrow(subLOFx1), nrow(subLOFx2)) + + data.frame(ccf=res$ccf, lag=res$lag, + D=distr.dist, + sd.D = distr.sd, + b1=b12[1], b2=b12[2], x1 = subLOFx1$x[1], x2 = subLOFx2$x[1], + #num.matches = sum(res$lines$match), + signature.length = signature.length, + matches.per.y = sum(res$lines$match) / signature.length, + #num.mismatches = sum(!res$lines$match), + mismatches.per.y = sum(!res$lines$match) / signature.length, + #cms = res$maxCMS, + cms.per.y = res$maxCMS / signature.length, + #cms2 = bulletr::maxCMS(subset(res$lines, type==1 | is.na(type))$match), + cms2.per.y = bulletr::maxCMS(subset(res$lines, type==1 | is.na(type))$match) / signature.length, + #non_cms = bulletr::maxCMS(!res$lines$match), + non_cms.per.y = bulletr::maxCMS(!res$lines$match) / signature.length, + #left_cms = max(knm[1] - km[1], 0), + left_cms.per.y = max(knm[1] - km[1], 0) / signature.length, + #right_cms = max(km[length(km)] - knm[length(knm)],0), + right_cms.per.y = max(km[length(km)] - knm[length(knm)],0) / signature.length, + #left_noncms = max(km[1] - knm[1], 0), + left_noncms.per.y = max(km[1] - knm[1], 0) / signature.length, + #right_noncms = max(knm[length(knm)]-km[length(km)],0), + right_noncms.per.y = max(knm[length(knm)]-km[length(km)],0) / signature.length, + #sumpeaks = sum(abs(res$lines$heights[res$lines$match])), + sumpeaks.per.y = sum(abs(res$lines$heights[res$lines$match])) / signature.length + ) + }) + + output$features <- DT::renderDataTable({ + if (is.null(features())) return(NULL) + + result <- as.data.frame(t(features())) + result <- cbind(Feature = rownames(result), result) + names(result)[2] <- "Value" + + clean_result <- result %>% + filter(Feature %in% c("ccf", "D", "signature.length", "matches.per.y", + "mismatches.per.y", "cms.per.y", "non_cms.per.y", + "sumpeaks.per.y")) %>% + mutate(Feature = c("CCF", "D", "Signature Length in Millimeters", "Matches Per Millimeter", + "Mismatches Per Millimeter", "CMS Per Millimeter", + "Non-CMS Per Millimeter", "Peak Sum Per Millimeter"), + Value = c(as.numeric(as.character(Value[1:2])), as.numeric(as.character(Value[3])) / 1000 * 1.5625, as.numeric(as.character(Value[4:8])) / 1.5625 * 1000)) + + clean_result$Value <- sprintf("%.4f", clean_result$Value) + + return(as_tibble(clean_result)) + }) + + observeEvent(input$confirm5, { + updateCheckboxInput(session, "stage5", value = TRUE) + }) + + observeEvent(input$back5, { + updateCheckboxInput(session, "stage4", value = FALSE) + }) + + observeEvent(input$confirm6, { + updateCheckboxInput(session, "stage6", value = TRUE) + }) + + observeEvent(input$back6, { + updateCheckboxInput(session, "stage5", value = FALSE) + }) + + output$rfpred <- renderText({ + if (is.null(features())) return(NULL) + + features <- features() + features$b1 <- gsub(".x3p", "", basename(as.character(features$b1))) + features$b2 <- gsub(".x3p", "", basename(as.character(features$b2))) + features$span <- span + + includes <- setdiff(names(features), c("b1", "b2", "data", "resID", "id.x", "id.y", "pred", "span", "forest")) + + load("data/rf.RData") + + matchprob <- sprintf("%.4f", predict(rtrees, newdata = features[,includes], type = "prob")[,2]) + if (matchprob == "0.0000") matchprob <- "< .0001" else if (matchprob == "1.0000") matchprob <- "> .9999" + + return(HTML(paste0("The same source similarity value is
", h1(matchprob)))) + }) + + observeEvent(input$restart, { + session$reload() + }) + +} + +shinyApp(ui = ui, server = server) diff --git a/app/Dump/bull/PGPD Barrel 9-1 Ld1.x3p b/app/Dump/bull/PGPD Barrel 9-1 Ld1.x3p new file mode 100644 index 0000000..2a90d47 Binary files /dev/null and b/app/Dump/bull/PGPD Barrel 9-1 Ld1.x3p differ diff --git a/app/Dump/dump.R b/app/Dump/dump.R new file mode 100644 index 0000000..ff0dde4 --- /dev/null +++ b/app/Dump/dump.R @@ -0,0 +1,72 @@ +library(shiny) +library(bslib) +options(rgl.useNULL = TRUE) +options(shiny.port = 4569) +options(shiny.host= "0.0.0.0") +library(rgl) +library(x3ptools) +library(bulletxtrctr) +library(shinyscreenshot) + +ui <- bootstrapPage( + screenshotButton(label = "Download Report", id = "allplot",filename="Bullet Comparison Report",scale=1), + uiOutput("allplot") + +) + +server <- function(input, output) +{ + + bull <- read_bullet("~/Desktop/csafe/bullet/bulletanalyzer/dump/bull") + # bull <- read_bullet("~/Desktop/bull") + bull$x3p <- lapply(bull$x3p,x3p_m_to_mum) + bull$x3p <- lapply(bull$x3p,function(x) y_flip_x3p(rotate_x3p(x,angle = -90))) + x3p_scaled <- x3p_interpolate(bull$x3p[[1]],resx=20) + output$plot1 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot2 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot3 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot4 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot5 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot6 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot7 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot8 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot9 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot10 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot11 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot12 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot13 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot14 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot15 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot16 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot17 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot18 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot19 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + output$plot20 <- renderRglwidget({image_x3p(x3p_scaled,zoom=1);rglwidget()}) + + output$allplot <- renderUI({layout_column_wrap( + width = 1/5, + rglwidgetOutput('plot1'), + rglwidgetOutput('plot2'), + rglwidgetOutput('plot3'), + rglwidgetOutput('plot4'), + rglwidgetOutput('plot5'), + rglwidgetOutput('plot6'), + rglwidgetOutput('plot7'), + rglwidgetOutput('plot8'), + rglwidgetOutput('plot9'), + rglwidgetOutput('plot10'), + rglwidgetOutput('plot11'), + rglwidgetOutput('plot12'), + rglwidgetOutput('plot13'), + rglwidgetOutput('plot14'), + rglwidgetOutput('plot15'), + rglwidgetOutput('plot16'), + rglwidgetOutput('plot17'), + rglwidgetOutput('plot18'), + rglwidgetOutput('plot19'), + rglwidgetOutput('plot20') + )}) +} + + +shinyApp(ui = ui, server = server) diff --git a/app/Dump/dump2.R b/app/Dump/dump2.R new file mode 100644 index 0000000..16a59a2 --- /dev/null +++ b/app/Dump/dump2.R @@ -0,0 +1,46 @@ + +# options(rgl.useNULL = TRUE) +library(rgl) +library(x3ptools) +library(bulletxtrctr) +# bull <- read_bullet("~/Desktop/bull") + +bull <- read_bullet("~/Desktop/csafe/bullet/bulletanalyzer/dump/bull") +bull$x3p <- lapply(bull$x3p,x3p_m_to_mum) +bull$x3p <- lapply(bull$x3p,function(x) y_flip_x3p(rotate_x3p(x,angle = -90))) +bull$x3p <- lapply(bull$x3p,function(x) x3p_add_hline(x,yintercept = 375, size = 10, color = "#e6bf98")) +x3p_scaled <- x3p_interpolate(bull$x3p[[1]],resx=8) +image_x3p(x3p_scaled,zoom=.75) + + +# snapshot3d("~/Downloads/test.png") + + + + + + + + + + + + + +options(rgl.useNULL = TRUE) +library(rgl) +library(x3ptools) +library(bulletxtrctr) +bull <- read_bullet("Dump/bull") +# bull <- read_bullet("~/Desktop/csafe/bullet/bulletanalyzer/dump/bull") +bull$x3p <- lapply(bull$x3p,x3p_m_to_mum) +bull$x3p <- lapply(bull$x3p,function(x) y_flip_x3p(rotate_x3p(x,angle = -90))) +bull$crosscut <- sapply(bull$x3p,x3p_crosscut_optimize) +bull$x3p <- lapply(bull$x3p,function(x) x3p_add_hline(x,yintercept = 51.5625, size = 20, color = "#ea2b1f")) +# x3p_scaled <- x3p_interpolate(bull$x3p[[1]],resx=8) +x3p_sampled <- x3p_sample(bull$x3p[[1]],m=5) +image_x3p(x3p_sampled,zoom=.75) + + +# snapshot3d("~/Downloads/test.png") + diff --git a/app/Dump/installation.txt b/app/Dump/installation.txt new file mode 100644 index 0000000..39529c5 --- /dev/null +++ b/app/Dump/installation.txt @@ -0,0 +1,18 @@ +## Ubuntu packages install +sudo apt install build-essential libz-dev gfortran libpng-dev libblas-dev liblapack-dev libjpeg-dev libxml2-dev libtiff5-dev libx11-dev libcurl4-openssl-dev libssl-dev libgl1-mesa-dev libglu1-mesa-dev + +## Install Google Chrome Command Line +wget https://dl.google.com/linux/direct/google-chrome-stable_current_amd64.deb +sudo dpkg -i google-chrome-stable_current_amd64.deb +sudo apt-get install -f +sudo dpkg -i google-chrome-stable_current_amd64.deb + +## Install R + +## Install R Packages +install.packages(c("shiny","shinyjs","shinyBS","shinycssloaders","shinyscreenshot","bslib","bsicons","ggplot2","randomForest","dplyr","DT","remotes","webshot2")) + +remotes::install_github("dmurdoch/rgl") +remotes::install_github("heike/x3ptools") +remotes::install_github("heike/bulletxtrctr") + diff --git a/app/css/styles.css b/app/css/styles.css new file mode 100755 index 0000000..c85b7b1 --- /dev/null +++ b/app/css/styles.css @@ -0,0 +1,203 @@ +h4 { + font-family: 'Montserrat', sans-serif; + font-weight: 700; +/* color: #003A70;*/ +} + +h3 { + font-family: 'Montserrat', sans-serif; + font-weight: 700; + color: #003A70; +} + +h2 { + font-family: 'Montserrat', sans-serif; + font-weight: 500; +} + +h1 { + font-family: 'Montserrat', sans-serif; + font-weight: 700; + font-size: 36px; +} + +body { + font-family: 'Montserrat', sans-serif; + font-weight: 500; + font-size: 16px; + color: #545859; +} + +html, body { + height: 100%; +} + +.well { + background-color: #003A70; + color: white; + border: 0px; + margin-left: 14px; +} + +.help-block { + color: white; +} + +#app-container { + height: 100%; + display: flex; + flex-direction: column; +} + +#global-navbar { + background-color: #FFFFFF; + overflow: hidden; + height: 120px; +} + +.container-fluid { + padding-left: 0px; + padding-right: 0px; +} + +.tab-content { + padding-left: 10px; + padding-right: 10px; + padding-top: 15px; +} + +.navbar-default { + background-color: #003A70; + padding-left: 10px; + margin-bottom: 20px; +} + +/* Targeting inactive tabs */ +.navbar-nav > li:not(.active) > a { + color: white; /* Sets the text color to white for inactive tabs */ +} + +/* Changing text color on hover for inactive tabs */ +.navbar-nav > li:not(.active) > a:hover { + color: white; /* Sets the hover text color to light grey */ +} + +#global-footer { + background-color: #003A70; + overflow: hidden; + height: 60px; +} + +#global-navbar a, #global-navbar img, #global-footer a #global-footer p { + float: left; + display: block; + text-align: center; + text-decoration: none; + line-height: 80px; + padding-left: 10px; +} + +#global-navbar img { + height: 70px; + margin-top: 5px; + margin-bottom: 5px; + vertical-align: middle; +} + +#global-footer img { + height: 60px; + margin-top: 00px; + margin-bottom: 10px; + margin-left: 20px; + vertical-align: middle; +} + +#global-footer a, #global-footer p { + color: white; + margin-top: 20px; +} + +#global-navbar a { + color: white; +} + +#global-navbar a:hover, #global-footer a:hover { + background-color: #ddd; + color: black; +} + +#global-navbar a.right-float, #global-footer a.right-float, #global-navbar p.right-float, #global-footer p.right-float { + float: right; + margin-right: 20px; +} + +#header-image img { + max-width: 100%; + width: 100%; + max-height: 80px; + height: 80px; + vertical-align: middle; + margin-top: 20px; +} + +#main-content { + flex: 1; +} + +#global-footer { + margin-top: auto; +} + +#customPopover { + position: fixed; + top: 50px; + left: 50%; + transform: translateX(-50%); + background-color: #f9f9f9; + border: 1px solid #ccc; + border-radius: 5px; + padding: 10px; + box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2); + z-index: 1050; + display: none; +} + +.btn-default { + color: #003A70; + background-color: white; + font-family: 'Montserrat', sans-serif; + font-weight: 700; +} + +.modal-content { + background-color: rgba(0, 58, 111, 0.8); /* Blue with 80% transparency */ + color: white; +} + +.modal-dialog { + position: fixed; /* Or 'absolute' depending on your layout */ + top: 30%; + left: 45%; + transform: translate(-45%, -30%); +} + +.responsive-text { + font-size: 2vw; +} +@media (max-width: 600px) { + .responsive-text { + font-size: 3vw; /* Larger on small screens */ + } +} + +.rounded-box { + border: 2px solid #ddd; + border-radius: 15px; + padding: 10px; + margin-bottom: 10px; + display: inline-block; +} + +.center-container { + text-align: center; +} diff --git a/app/images/BulletAnalyzr-Design-2.png b/app/images/BulletAnalyzr-Design-2.png new file mode 100644 index 0000000..99fa0cd Binary files /dev/null and b/app/images/BulletAnalyzr-Design-2.png differ diff --git a/app/images/BulletAnalzr-Mark-2.png b/app/images/BulletAnalzr-Mark-2.png new file mode 100644 index 0000000..a5deb05 Binary files /dev/null and b/app/images/BulletAnalzr-Mark-2.png differ diff --git a/app/server.R b/app/server.R new file mode 100644 index 0000000..10be643 --- /dev/null +++ b/app/server.R @@ -0,0 +1,656 @@ +## Load Libraries +library(shiny) +library(shinyjs) +library(shinyBS) +library(ggplot2) +library(bslib) +library(bsicons) +library(shinycssloaders) +library(randomForest) +library(dplyr) +library(DT) + +## Load Bullet Libraries +options(rgl.useNULL = TRUE) +library(rgl) +library(x3ptools) +library(bulletxtrctr) + +## Config +options(shiny.maxRequestSize = 30*1024^2) +addResourcePath("images", "images") + +################################################################################# +## Helper Functions +################################################################################# +## Render RGL Widget UI +parse_rglui <- function(x) +{ + card( + card_header(class = "bg-dark",paste0("Land ",x)), + max_height = 300, + full_screen = FALSE, + rglwidgetOutput(paste0("x3prgl",x),height=300,width=400), + ) +} +parse_rgluiprev <- function(x) +{ + card( + card_header(class = "bg-dark",paste0("Land ",x)), + max_height = 300, + full_screen = FALSE, + rglwidgetOutput(paste0("x3prglprev",x),height=300,width=400), + ) +} + +## Render Land into image with CrossCut line +render_land <- function(src,x3p,ccut) +{ + imgsrc <- gsub(".x3p$",".png",src) + image_x3p(x3p_sample(x3p_add_vline(x3p,xintercept = ccut, size = 20, color = "#ea2b1f"),m=5),zoom=1) + snapshot3d(imgsrc,webshot=TRUE) + return(imgsrc) +} +################################################################################# +################################################################################# + + +server <- function(input, output, session) { + + ################################################################################# + ## Bullet Data Upload and Storage + ################################################################################# + observeEvent(input$confirm_autonomous,{updateTabsetPanel(session, "prevreport", selected = "Upload Bullet")}) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Bullet Data Upload and Storage + ################################################################################# + ## Reactive object to hold the bullet and comparison data + bulldata <- reactiveValues(allbull=data.frame(),cbull=data.frame(),comparison=NULL) + + ## Bullet Land Files Input + output$bul_x3pui <- renderUI({fileInput("bul_x3p", "Select Bullet Land x3p files", accept = ".x3p",multiple=TRUE)}) + + ## Push current bullet data to all bullet data object + observeEvent(input$up_bull,{ + # if(nrow(bulldata$cbull)==0) return(NULL) + allbull <- bulldata$allbull + allbull <- allbull[!(allbull$bullet %in% input$bul_x3p_name),] + bull <- bulldata$cbull + bull$bullet <- input$bul_x3p_name + bull$land <- 1:nrow(bull) + bulldata$allbull <- rbind(allbull,bull) + disable("up_bull") + }) + + ## Manipulate Rotation Current Bullet Loaded + # observeEvent(input$rot90,{ + # if(is.null(input$bul_x3p)) return(NULL) + # bull <- bulldata$cbull + # bull$x3p <- lapply(bull$x3p,function(x) y_flip_x3p(rotate_x3p(x,angle = -90))) + # bulldata$cbull <- bull + # }) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Preview Bullets while Uploading Bullet lands + ################################################################################# + output$lpupload <- renderUI({ + if(is.null(input$bul_x3p)) return(NULL) + disable("up_bull") + progress <- shiny::Progress$new();on.exit(progress$close()) + + ## Refresh on Tab Change + temp_refresh <- input$prevreport + + # Create Temporary Directory and save bullets in it + temp_dir <- tempfile() + dir.create(temp_dir) + file.copy(input$bul_x3p$datapath, paste0(temp_dir, "/", input$bul_x3p$name)) + + ## Read Bullet + progress$set(message = "Reading Bullets", value = .25) + bull <- read_bullet(temp_dir) + bull$x3p <- lapply(bull$x3p,x3p_m_to_mum) + bull$x3pv <- bull$x3p + # bull$x3p <- lapply(bull$x3p,function(x) y_flip_x3p(rotate_x3p(x,angle = -90))) + bull$md5sum <- tools::md5sum(bull$source) + bull$filename <- basename(bull$source) + bulldata$cbull <- bull + + ## Render Bullet + progress$set(message = "Rendering Previews", value = .75) + for(idx in 1:nrow(bull)) + { + local({ + cidx <- idx + output[[paste0("x3prgl",idx)]] <- renderRglwidget({ + image_x3p(x3p_sample(bull$x3pv[[cidx]],m=5),zoom=1) + rglwidget() + }) + }) + } + + ## Enable Upload Button + enable("up_bull") + + ## UI + layout_column_wrap( + width = 1/3, + !!!lapply(1:nrow(bull),parse_rglui) + ) + }) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Preview Bullet Selection + ################################################################################# + output$prevSelUI <- renderUI({ + if(nrow(bulldata$allbull)==0) return(NULL) + allbull <- bulldata$allbull + selectInput("prev_bul","Preview Bullet",choices=unique(allbull$bullet),selected=NULL,multiple = FALSE) + }) + output$lpreview <- renderUI({ + if(nrow(bulldata$allbull)==0) return(NULL) + if(length(input$prev_bul)==0) return(NULL) + progress <- shiny::Progress$new();on.exit(progress$close()) + + ## Refresh on Tab Change + temp_refresh <- input$prevreport + + ## Render Bullet + allbull <- bulldata$allbull + bull <- allbull[allbull$bullet==input$prev_bul,] + + progress$set(message = "Rendering Previews", value = .75) + for(idx in 1:nrow(bull)) + { + local({ + cidx <- idx + output[[paste0("x3prglprev",idx)]] <- renderRglwidget({ + image_x3p(x3p_sample(bull$x3pv[[cidx]],m=5),zoom=1) + rglwidget() + }) + }) + } + + ## UI + layout_column_wrap( + width = 1/3, + !!!lapply(1:nrow(bull),parse_rgluiprev) + ) + }) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Compare Bullet Selection and processing + ################################################################################# + output$bull_sel <- renderUI({ + if(nrow(bulldata$allbull)==0) return(NULL) + allbull <- bulldata$allbull + checkboxGroupInput( + "bullcompgroup", + label = "Selects Bullets to Compare", + choices = unique(bulldata$allbull$bullet), + selected = unique(bulldata$allbull$bullet) + ) + }) + + observeEvent(input$doprocess,{ + if(length(input$bullcompgroup)==0) return(NULL) + progress <- shiny::Progress$new();on.exit(progress$close()) + + ## Fetch All Bullets + bullets <- bulldata$allbull + resolution <- x3p_get_scale(bullets$x3p[[1]]) + + ## Get the ideal Cross Sections + progress$set(message = "Get the ideal Cross Sections", value = 0) + bullets$crosscut <- sapply(bullets$x3p,x3p_crosscut_optimize) + bullets$ccdata <- mapply(x3p_crosscut,bullets$x3p,bullets$crosscut,SIMPLIFY=FALSE) + + ## Get the Groove Locations + progress$set(message = "Get the Groove Locations", value = .05) + bullets$grooves <- lapply(bullets$ccdata,function(x) cc_locate_grooves(x,method = "middle", adjust = 30, return_plot = FALSE)) + + ## Extracting Signal + progress$set(message = "Extracting Signal", value = .1) + bullets$sigs <- mapply(function(ccdata,grooves) cc_get_signature(ccdata, grooves, span1 = 0.75, span2 = 0.03) ,bullets$ccdata,bullets$grooves,SIMPLIFY=FALSE) + bullets$bulletland <- paste0(bullets$bullet,"-", bullets$land) + lands <- unique(bullets$bulletland) + + ## Align Signal + progress$set(message = "Align Signal", value = .15) + comparisons <- data.frame(expand.grid(land1 = lands, land2 = lands), stringsAsFactors = FALSE) + comparisons$aligned <- mapply(function(x,y,bullets) sig_align(bullets$sigs[bullets$bulletland == x][[1]]$sig, bullets$sigs[bullets$bulletland == y][[1]]$sig),comparisons$land1,comparisons$land2,MoreArgs=list(bullets=bullets),SIMPLIFY=FALSE) + + ## Evaluating Features + progress$set(message = "Evaluating Features", value = .2) + comparisons$ccf0 <- sapply(comparisons$aligned,function(x) extract_feature_ccf(x$lands)) + comparisons$lag0 <- sapply(comparisons$aligned,function(x) extract_feature_lag(x$lands)) + comparisons$D0 <- sapply(comparisons$aligned,function(x) extract_feature_D(x$lands)) + comparisons$length0 <- as.numeric(sapply(comparisons$aligned,function(x) extract_feature_length(x$lands))) + comparisons$overlap0 <- sapply(comparisons$aligned,function(x) extract_feature_overlap(x$lands)) + + ## Evaluating Striation Marks + progress$set(message = "Evaluating Striation Marks", value = .25) + comparisons$striae <- lapply(comparisons$aligned,sig_cms_max,span=75) + + ## Evaluating Features + progress$set(message = "Evaluating Features", value = .3) + comparisons$cms_per_mm <- mapply(function(x,y,resolution) extract_feature_cms_per_mm(x$lines,y$lands,resolution),comparisons$striae,comparisons$striae,MoreArgs=list(resolution=resolution),SIMPLIFY=FALSE) + comparisons$matches0 <- as.numeric(sapply(comparisons$striae,function(s) bulletxtrctr:::extract_helper_feature_n_striae(s$lines, type = "peak", match = TRUE))) + comparisons$mismatches0 <- as.numeric(sapply(comparisons$striae,function(s) bulletxtrctr:::extract_helper_feature_n_striae(s$lines, type = "peak", match = FALSE))) + + ## Extracting Features + progress$set(message = "Extracting Features", value = .35) + comparisons$bulletA <- sapply(strsplit(as.character(comparisons$land1),"-"),"[[",1) + comparisons$bulletB <- sapply(strsplit(as.character(comparisons$land2),"-"),"[[",1) + comparisons$landA <- sapply(strsplit(as.character(comparisons$land1),"-"),"[[",2) + comparisons$landB <- sapply(strsplit(as.character(comparisons$land2),"-"),"[[",2) + comparisons$features <- mapply(extract_features_all,comparisons$aligned,comparisons$striae,MoreArgs=list(resolution=resolution),SIMPLIFY=FALSE) + comparisons$legacy_features <- mapply(extract_features_all_legacy,comparisons$striae,MoreArgs=list(resolution=resolution),SIMPLIFY=FALSE) + + ## Scaling Features + progress$set(message = "Scaling Features", value = .4) + features <- tidyr::unnest(comparisons[,c("land1", "land2", "ccf0", "bulletA", "bulletB", "landA", "landB", "features")]) + features <- features %>% mutate(cms = cms_per_mm,matches = matches_per_mm,mismatches = mismatches_per_mm,non_cms = non_cms_per_mm) + + ## Predicting RandomForest Scores + progress$set(message = "Predicting RandomForest Scores", value = .45) + features$rfscore <- predict(rtrees, newdata = features, type = "prob")[,2] + + ## Preparing Data for Report + progress$set(message = "Preparing Report Data", value = .5) + bullet_scores <- features %>% group_by(bulletA, bulletB) %>% tidyr::nest() + bullet_scores$bullet_score <- sapply(bullet_scores$data,function(d) max(compute_average_scores(land1 = d$landA, land2 = d$landB, d$rfscore))) + bullet_scores$data <- lapply(bullet_scores$data,function(d) cbind(d,samesource=bullet_to_land_predict(land1 = d$landA, land2 = d$landB, d$rfscore,difference=0.1))) + + + # Rendering Bullet Images for Report + bullets$x3pimg <- NA + for(idx in 1:nrow(bullets)) + { + progress$set(message = "Rendering Report Objects", value = round(seq(from=.55,to=.85,length.out=nrow(bullets)),2)[idx]) + bullets$x3pimg[idx] <- render_land(bullets$source[idx],bullets$x3pv[[idx]],bullets$crosscut[idx]) + } + + ## Saving Report Data + progress$set(message = "Preparing Report", value = .9) + bulldata$comparison <- list(bullets=bullets,comparisons=comparisons,features_scaled=features,bullet_scores=bullet_scores) + + ## Update the selected Panel + updateTabsetPanel(session, "prevreport", selected = "Comparison Report") + + # Debug + # saveRDS(list(comparison = bulldata$comparison),"~/Downloads/aa.RDS") + }) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Generate Bullet Comparison Report UI + ################################################################################# + ## Side Panel UI + output$reportSelUI <- renderUI({ + if(is.null(bulldata$comparison)) return(NULL) + all_bullets <- unique(bulldata$comparison$bullet_scores$bulletA) + list( + selectInput("comp_bul1","Compare Bullet",choices=all_bullets,selected=all_bullets[1]), + selectInput("comp_bul2","With Bullet",choices=all_bullets,selected=all_bullets[2]), + hr() + ) + }) + + ## Side Panel UI Download Report + output$reportDownUI <- renderUI({ + if(is.null(bulldata$comparison)) return(NULL) + fluidRow(column(12,screenshotButton(label = "Download Report", id = "reportUI",filename="Bullet Comparison Report",scale=2),align="center")) + }) + + ## Main Panel UI Bullet Comparison Report + output$reportUI <- renderUI({ + if(is.null(bulldata$comparison)) return(NULL) + if(is.null(input$comp_bul1) | is.null(input$comp_bul2)) return(NULL) + + ## Bullet Comparison Report + BullComp <- list( + fluidRow( + column(6,plotOutput("bull_comp")), + column(6,plotOutput("land_comp")) + ), + br(),br(), + fluidRow(column(12,plotOutput("land_visCC"),align="center")), + br(),br(), + fluidRow(column(12,plotOutput("land_visSig"),align="center")), + br() + ) + + ## Land Comparison Collapsable Report + LandComp <- list() + bullet_scores <- bulldata$comparison$bullet_scores + bullet_scores <- bullet_scores[bullet_scores$bulletA==input$comp_bul1 & bullet_scores$bulletB==input$comp_bul2,] + bullet_scores$data[[1]] <- bullet_scores$data[[1]][bullet_scores$data[[1]]$samesource,] + if(nrow(bullet_scores$data[[1]])>0) + { + ## Collect Land wise Data + bsldata <- bullet_scores$data[[1]] + odridx <- order(bsldata$rfscore,decreasing=TRUE) + + ## Generate Collapsible UI Panel List in a loop + bsCollapsePanelList <- list() + for(idx in 1:length(odridx)) + { + ######################################################################################################### + ## Data Table Comparison + ######################################################################################################### + BullCompBulls <- bulldata$comparison$bullets + temptable <- data.frame( + Feature = c("Left Land File","Left Land MD5","Right Land File","Right Land MD5","Cross Correlation Function","Mean Distance bw Matching Striae","Signature Length in Millimeters","Matches Per Millimeter","Mismatches Per Millimeter","CMS Per Millimeter","Non-CMS Per Millimeter","Peak Sum Per Millimeter"), + Value = c( + BullCompBulls$filename[BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[idx]]], + BullCompBulls$md5sum[BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[idx]]], + BullCompBulls$filename[BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[idx]]], + BullCompBulls$md5sum[BullCompBulls$bullet==input$comp_bul2 & BullCompBulls$land == bsldata$landB[odridx[idx]]], + round(bsldata$ccf[odridx[idx]],3), + round(bsldata$D[odridx[idx]],3), + round(bsldata$length_mm[odridx[idx]],3), + round(bsldata$matches_per_mm[odridx[idx]],3), + round(bsldata$mismatches_per_mm[odridx[idx]],3), + round(bsldata$cms_per_mm[odridx[idx]],3), + round(bsldata$non_cms_per_mm[odridx[idx]],3), + round(bsldata$sum_peaks[odridx[idx]],3) + ) + ) + temptable_dt <- datatable(temptable,rownames=FALSE,options = list(paging = FALSE,ordering=FALSE,searching=FALSE,bLengthChange = FALSE,bInfo = FALSE)) + ######################################################################################################### + ######################################################################################################### + + ######################################################################################################### + ## RGL Render Comparison + ######################################################################################################### + local({ + cidx <- idx + BullCompBulls <- bulldata$comparison$bullets + rglLidx <- which(BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[cidx]]) + rglRidx <- which(BullCompBulls$bullet==input$comp_bul2 & BullCompBulls$land == bsldata$landB[odridx[cidx]]) + rglL <- BullCompBulls$x3pimg[[rglLidx]] + rglR <- BullCompBulls$x3pimg[[rglRidx]] + output[[paste0("rglWinL",idx)]] = renderImage({list(src = rglL, contentType = 'image/png')}, deleteFile = FALSE) + output[[paste0("rglWinR",idx)]] = renderImage({list(src = rglR, contentType = 'image/png')}, deleteFile = FALSE) + }) + temp_rgl <- fluidRow( + column(1,), + column(5,imageOutput(paste0("rglWinL",idx)),align="left"), + column(5,imageOutput(paste0("rglWinR",idx)),align="left"), + column(1,) + ) + ######################################################################################################### + ######################################################################################################### + + + ######################################################################################################### + ## Groove Plot + ######################################################################################################### + # local({ + # cidx <- idx + # BullCompBulls <- bulldata$comparison$bullets + # GroovePlotLidx <- which(BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[idx]]) + # GroovePlotRidx <- which(BullCompBulls$bullet==input$comp_bul2 & BullCompBulls$land == bsldata$landB[odridx[idx]]) + # output[[paste0("GroovePlotL",idx)]] = renderPlot({ + # BullCompBulls$grooves[[GroovePlotLidx]]$plot + + # xlab("Position along width of Land in Microns (1 Millimeter = 1000 Microns)") + + # ylab("Surface Height in Microns") + + # ggtitle(paste0("Location of the grooves in Land : ",bsldata$land1[odridx[cidx]])) + # }) + # output[[paste0("GroovePlotR",idx)]] = renderPlot({ + # BullCompBulls$grooves[[GroovePlotRidx]]$plot + + # xlab("Position along width of Land in Microns (1 Millimeter = 1000 Microns)") + + # ylab("Surface Height in Microns") + + # ggtitle(paste0("Location of the grooves in Land : ",bsldata$land2[odridx[cidx]])) + # }) + # }) + local({ + cidx <- idx + BullCompBulls <- bulldata$comparison$bullets + GroovePlotLidx <- which(BullCompBulls$bullet==input$comp_bul1 & BullCompBulls$land == bsldata$landA[odridx[idx]]) + GroovePlotRidx <- which(BullCompBulls$bullet==input$comp_bul2 & BullCompBulls$land == bsldata$landB[odridx[idx]]) + GroovesL <- as.numeric(BullCompBulls$grooves[[GroovePlotLidx]]$groove) + GroovesR <- as.numeric(BullCompBulls$grooves[[GroovePlotRidx]]$groove) + CCDataL <- BullCompBulls$ccdata[[GroovePlotLidx]] - GroovesL[1] + CCDataR <- BullCompBulls$ccdata[[GroovePlotRidx]] - GroovesR[1] + output[[paste0("GroovePlotL",idx)]] = renderPlot({ + CCDataL %>% + ggplot(aes(x = x, y = value)) + + geom_line() + + theme_bw()+ + geom_vline(xintercept = 0, colour = "blue") + + geom_vline(xintercept = GroovesL[2]-GroovesL[1], colour = "blue") + + scale_x_continuous(breaks=c(0,round(as.numeric(GroovesL[2]-GroovesL[1]),0),round(seq(min(CCDataL$x),max(CCDataL$x),by=500),-2))) + + xlab("Position along width of Land in Microns\n(1 Millimeter = 1000 Microns)") + + ylab("Surface Height in Microns") + + ggtitle(paste0("Location of the grooves in Land : ",bsldata$land1[odridx[cidx]]))+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + plot.title = element_text(size=22,face="bold"), + axis.text.x = element_text(angle = 90, hjust = 1) + ) + }) + output[[paste0("GroovePlotR",idx)]] = renderPlot({ + CCDataR %>% + ggplot(aes(x = x, y = value)) + + geom_line() + + theme_bw()+ + geom_vline(xintercept = 0, colour = "blue") + + geom_vline(xintercept = GroovesR[2]-GroovesR[1], colour = "blue") + + scale_x_continuous(breaks=c(0,round(as.numeric(GroovesR[2]-GroovesR[1]),0),round(seq(min(CCDataR$x),max(CCDataR$x),by=500),-2))) + + xlab("Position along width of Land in Microns\n(1 Millimeter = 1000 Microns)") + + ylab("Surface Height in Microns") + + ggtitle(paste0("Location of the grooves in Land : ",bsldata$land2[odridx[cidx]]))+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + plot.title = element_text(size=22,face="bold"), + axis.text.x = element_text(angle = 90, hjust = 1) + ) + }) + }) + temp_groove <- fluidRow( + column(6,plotOutput(paste0("GroovePlotL",idx)),align="center"), + column(6,plotOutput(paste0("GroovePlotR",idx)),align="center") + ) + ######################################################################################################### + ######################################################################################################### + + + ######################################################################################################### + ## Signal Comparison + ######################################################################################################### + local({ + cidx <- idx + BullCompComps <- bulldata$comparison$comparisons + + SigPlotData <- BullCompComps$aligned[ + (BullCompComps$bulletA == input$comp_bul1)& + (BullCompComps$bulletB == input$comp_bul2)& + (BullCompComps$landA == bsldata$landA[odridx[idx]])& + (BullCompComps$landB == bsldata$landB[odridx[idx]]) + ][[1]]$lands + SigPlotData <- tidyr::gather(SigPlotData,Signal, value, sig1, sig2) + SigPlotData$Signal[SigPlotData$Signal=="sig1"] <- "Left Land" + SigPlotData$Signal[SigPlotData$Signal=="sig2"] <- "Right Land" + output[[paste0("SigPlot",idx)]] = renderPlot({ + ggplot(SigPlotData,aes(x = x, y = value, colour = Signal)) + + geom_line(na.rm=TRUE) + + theme_bw() + + scale_color_brewer(palette = "Dark2") + + xlab("Position along width of Land in Microns (1 Millimeter = 1000 Microns)") + + ylab("Signal in Microns") + + ggtitle("Alignment of two Bullet Lands")+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + legend.title=element_text(size=18), + legend.text=element_text(size=16), + plot.title = element_text(size=22,face="bold"), + axis.text.x = element_text(angle = 90, hjust = 1) + ) + }) + }) + temp_signal <- fluidRow(column(12,plotOutput(paste0("SigPlot",idx)),align="center")) + ######################################################################################################### + ######################################################################################################### + + ## Combine Results + panel_name <- paste0(bsldata$land1[odridx[idx]]," vs ",bsldata$land2[odridx[idx]]," (RF Score = ",round(bsldata$rfscore[odridx[idx]],4),")") + # bsCollapsePanelList[[idx]] <- bsCollapsePanel(panel_name, temptable_dt, br(), temp_groove, br(), temp_signal, style = "primary") + bsCollapsePanelList[[idx]] <- bsCollapsePanel(panel_name, temptable_dt, br(),temp_rgl, temp_groove, br(), temp_signal, style = "primary") + } + + ## Generate Collapsible UI Panel + LandComp <- do.call(bsCollapse,args=c(id = "collapseExample",multiple=TRUE,bsCollapsePanelList)) + } + + ## If no Land Match + if(nrow(bullet_scores$data[[1]])==0) LandComp$children <- list(fluidRow(column(12,h3("No Land Matches in this Bullet Pair."),align="center")),br()) + + ## Return Full Collapsible Report + return(c(BullComp,LandComp$children)) + }) + ################################################################################# + ################################################################################# + + + ################################################################################# + ## Generate Bullet Comparison Report Server Outputs + ################################################################################# + ## Bullet Comparison Heatmap + output$bull_comp <- renderPlot({ + if(is.null(bulldata$comparison)) return(NULL) + + bullet_scores <- bulldata$comparison$bullet_scores + bullet_scores$selsource <- FALSE + bullet_scores$selsource[bullet_scores$bulletA==input$comp_bul1 & bullet_scores$bulletB==input$comp_bul2] <- TRUE + bullet_scores$selsource[bullet_scores$bulletB==input$comp_bul1 & bullet_scores$bulletA==input$comp_bul2] <- TRUE + bullet_scores %>% + ggplot(aes(x = bulletA, y = bulletB, fill = bullet_score, colour=selsource)) + + geom_tile() + + labs(fill="Bullet Score") + + scale_fill_gradient2(low = "grey80", high = "darkorange", midpoint = .5) + + scale_colour_manual(values = c("black", "black")) + + geom_tile(size = 1, data = bullet_scores %>% filter(selsource)) + + geom_text(aes(label = round(bullet_score, 2)),size=6) + + xlab("Bullet Name") + + ylab("Bullet Name") + + guides(colour="none") + + coord_equal() + + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + legend.title=element_text(size=18), + legend.text=element_text(size=16) + ) + }) + + ## Land Comparison Heatmap + output$land_comp <- renderPlot({ + if(is.null(bulldata$comparison)) return(NULL) + if(is.null(input$comp_bul1) | is.null(input$comp_bul2)) return(NULL) + + bullet_scores <- bulldata$comparison$bullet_scores + bullet_scores <- bullet_scores[bullet_scores$bulletA==input$comp_bul1 & bullet_scores$bulletB==input$comp_bul2,] + features <- bullet_scores %>% tidyr::unnest(data) + features %>% + ggplot(aes(x = landA, y = landB, fill = rfscore, colour=samesource)) + + geom_tile() + + labs(fill="Land Score") + + scale_fill_gradient2(low = "grey80", high = "darkorange", midpoint = .5) + + scale_colour_manual(values = c("black", "black")) + + geom_tile(size = 1, data = features %>% filter(samesource)) + + geom_text(aes(label = round(rfscore, 2)),size=6) + + xlab(paste0("Land Name","(Bullet ",features$bulletA[1],")")) + + ylab(paste0("Land Name","(Bullet ",features$bulletB[1],")")) + + guides(colour="none") + + coord_equal()+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + legend.title=element_text(size=18), + legend.text=element_text(size=16) + ) + }) + + ## Visualize Cross Cuts + output$land_visCC <- renderPlot({ + if(is.null(bulldata$comparison)) return(NULL) + if(is.null(input$comp_bul1) | is.null(input$comp_bul2)) return(NULL) + + bullets <- bulldata$comparison$bullets + bullets <- bullets[bullets$bullet %in% c(input$comp_bul1,input$comp_bul2),] + crosscuts <- bullets %>% tidyr::unnest(ccdata) + crosscuts$x <- crosscuts$x/1000 + CCplot <- crosscuts %>% + ggplot(aes(x = x, y = value)) + + geom_line() + + facet_grid(bullet~land, labeller="label_both") + + theme_bw()+ + xlab("Position along width of Land in Millimeters (1 Millimeter = 1000 Microns)") + + ylab("Surface Height in Microns") + + ggtitle("Cross-section of the bullet land at the ideal cross-section location")+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + legend.title=element_text(size=18), + legend.text=element_text(size=16), + plot.title = element_text(size=22,face="bold"), + strip.text = element_text(size=18), + axis.text.x = element_text(angle = 90, hjust = 1) + ) + return(CCplot) + }) + + ## Visualize Signals + output$land_visSig <- renderPlot({ + if(is.null(bulldata$comparison)) return(NULL) + if(is.null(input$comp_bul1) | is.null(input$comp_bul2)) return(NULL) + + bullets <- bulldata$comparison$bullets + bullets <- bullets[bullets$bullet %in% c(input$comp_bul1,input$comp_bul2),] + signatures <- bullets %>% select(source,bullet,land, sigs) %>% tidyr::unnest(sigs) + signatures$x <- signatures$x/100 + Sigplot <- signatures %>% + filter(!is.na(sig),!is.na(raw_sig)) %>% + ggplot(aes(x = x)) + + geom_line(aes(y = raw_sig), colour = "grey70",show.legend = T) + + geom_line(aes(y = sig), colour = "grey30",show.legend = T) + + facet_grid(bullet~land, labeller="label_both") + + ylim(c(-5,5)) + + theme_bw() + + xlab("Position along width of Land in Millimeters (1 Millimeter = 1000 Microns)") + + ylab("Signal in Microns") + + ggtitle("Raw and LOESS-smoothed Signal for Bullet Profile")+ + theme( + axis.text=element_text(size=16), + axis.title=element_text(size=18), + legend.title=element_text(size=18), + legend.text=element_text(size=16), + plot.title = element_text(size=22,face="bold"), + strip.text = element_text(size=18), + axis.text.x = element_text(angle = 90, hjust = 1) + ) + return(Sigplot) + }) + ################################################################################# + ################################################################################# +} \ No newline at end of file diff --git a/app/ui.R b/app/ui.R new file mode 100644 index 0000000..f49ee88 --- /dev/null +++ b/app/ui.R @@ -0,0 +1,73 @@ +## Load Libraries +library(shiny) +library(shinyjs) +library(shinyBS) +library(ggplot2) +library(bslib) +library(bsicons) +library(shinycssloaders) +library(shinyscreenshot) +library(randomForest) +library(DT) + +## Load Bullet Libraries +options(rgl.useNULL = TRUE) +library(rgl) + +options(shiny.maxRequestSize = 30*1024^2) +addResourcePath("images", "images") + +ui <- shinyUI({ + fluidPage(title = "BulletAnalyzr", + # theme = bs_theme(), + useShinyjs(), + tags$head( + tags$link( + href = "https://fonts.googleapis.com/css?family=Montserrat:400,500,700,900|Ubuntu:400,500,700", + rel = "stylesheet", + type = "text/css" + ), + tags$link(rel = "shortcut icon", href = "favicon.png", type = "image/png"), + tags$link(rel = "icon", href = "favicon.png", type = "image/png") + ), + includeCSS("css/styles.css"), + tags$div(id="app-container", + fluidRow( + column(width = 4,tags$a(target = "_blank", href="https://forensicstats.org", tags$img(src = "images/BulletAnalzr-Mark-2.png", width="500px"))), + column(width = 4,br()), + column(width = 4,tags$a(target = "_blank", href="https://forensicstats.org", tags$img(src = "images/BulletAnalyzr-Design-2.png", width="500px")),align="right"), + ), + tags$div(id="main-content", + # navbarPage(title = div(div(id = "img-id",img(src = "csafe_tools_blue_h.png", alt="Logo", height = "40px"))), + navbarPage(NULL, + tabPanel("Home", + source("ui_inner.R", local = TRUE)$value, + ), + tabPanel( + "About", + h4(HTML("CSAFE Tools is a software suite of state-of-the-art statistical libraries designed to assist practitioners in analyzing forensic data. This work was developed in collaboration with the Center for Statistics and Applications in Forensic Evidence (CSAFE) at Iowa State University and Omni Analytics Group. These procedures are fully open-source and transparent. For more details on the underlying code, please see the GitHub repository for the companion R package.")), + br(), br(), + h4(HTML("This software is an implementation of a front-end to the bulletr package.")), + h4(HTML("This application will walk through the steps used to programmatically determine the probability that two bullets were fired from the same gun. During discharge, as a bullet travels out of the chamber, it is imprinted with a groove signature that is unique to that gun’s barrel. The grooved pattern of a gun’s barrel is so distinct that the striations that are imprinted on a set of fired bullet need only be matched across a small region for there to be statistical confidence of a match; therefore probabilistic comparisons can be made at the bullet land level which represent only one-sixth of a bullet.

+ Hare, E., Hofmann, H., and Carriquiry, A., Algorithmic Approaches to Match Degraded Land Impressions. Law, Probability and Risk, mgx018, https://doi.org/10.1093/lpr/mgx018
+ Hare, E., Hofmann, H., and Carriquiry, A., Automatic Matching of Bullet Land Impressions. Annals of Applied Statistics. doi: 10.1214/17-AOAS1080" + )), + hr() + ), + tabPanel("Instructions",), + tabPanel("Contact",), + # tags$li( + # class = "dropdown", + # tags$img(src = "csafe_tools_blue_h.png", style = "height: 50px; padding-top: 10px; padding-right: 10px;"), + # style = "position: absolute; right: 0px; top: 100px;" + # ) + ))), + # Footer + tags$div(id="global-footer", + fluidRow( + column(width = 4,tags$img(src="csafe_tools_blue_h.png", alt="Logo", height = "40px")), + column(width = 4,tags$p("195 Durham Center, 613 Morrill Road, Ames, Iowa, 50011")), + column(width = 4,tags$p("(C) 2023 | All Rights Reserved", class="right-float")) + ) + )) +}) diff --git a/app/ui_inner.R b/app/ui_inner.R new file mode 100644 index 0000000..d0f413a --- /dev/null +++ b/app/ui_inner.R @@ -0,0 +1,70 @@ +sidebarLayout(tags$div(id="my-sidebar", + sidebarPanel(width=3, + fluidPage( + + ## Welcome Page + conditionalPanel(condition="input.prevreport == 'Welcome'", + div(id = "autonomous", + tags$h1(class = "responsive-text","GET STARTED"), + br(), + helpText("Press the following button to start using the app by uploading the bullet data."), + br(), + actionButton("confirm_autonomous", "Begin")#, icon = icon("check")) + ), + ), + + ## Bullet Select and manipulate Input + conditionalPanel(condition="input.prevreport == 'Upload Bullet'", + fluidRow(column(12,uiOutput("bul_x3pui"))), + # fluidRow(column(12,actionButton("rot90", label = "Rotate Lands by 90 Degree"),align="center")), + hr() + ), + conditionalPanel(condition="input.prevreport == 'Preview Bullet'", + uiOutput("prevSelUI"), + ), + conditionalPanel(condition="input.prevreport == 'Comparison Report'", + uiOutput("reportSelUI"), + ), + + ## Bullet Add to Comparison UI + conditionalPanel(condition="input.prevreport == 'Upload Bullet'", + fluidRow( + column(12,textInput("bul_x3p_name", label="Bullet Name",value="",placeholder="Bullet Name Here ...")), + column(12,actionButton("up_bull", label = "Add Bullet to Comparison List"),align="center") + ), + hr(), + ), + + ## Bullet Comparison UI + conditionalPanel(condition="input.prevreport == 'Upload Bullet'", + fluidRow( + column(12,uiOutput("bull_sel")), + column(12,actionButton("doprocess", label = "Compare Bullets"),align="center") + ), + ), + + ## Download Report Button + conditionalPanel(condition="input.prevreport == 'Comparison Report'", + uiOutput("reportDownUI"), + ), + ))), + mainPanel( + tabsetPanel(id="prevreport", + + ## Welcome + tabPanel("Welcome", + h3("WELCOME TO BULLETANALYZR!"), + p("Our innovation combines 3D imagery and sophisticated algorithms to revolutionize bullet analysis. This prototype demonstrates how our methods can calculate the likelihood of the observed similarity if two bullets originated from the same firearm versus different firearms. It's a work in progress, evolving through feedback from diverse communities."), + ), + + ## Upload Bullet RGL Windows + tabPanel("Upload Bullet",uiOutput("lpupload")), + + ## Upload Bullet RGL Windows + tabPanel("Preview Bullet",uiOutput("lpreview")), + + ## Comparison Report + tabPanel("Comparison Report",withSpinner(uiOutput("reportUI"))) + ) + ) +) \ No newline at end of file diff --git a/app/www/csafe_tools_blue.png b/app/www/csafe_tools_blue.png new file mode 100755 index 0000000..e868690 Binary files /dev/null and b/app/www/csafe_tools_blue.png differ diff --git a/app/www/csafe_tools_blue_h.png b/app/www/csafe_tools_blue_h.png new file mode 100644 index 0000000..204be27 Binary files /dev/null and b/app/www/csafe_tools_blue_h.png differ diff --git a/app/www/favicon.png b/app/www/favicon.png new file mode 100644 index 0000000..bf01766 Binary files /dev/null and b/app/www/favicon.png differ