####

# Main Shiny App ####

####

#' registerSpatialData

#'

#' A mini shiny app to for registering images and spatial coordinates of multiple consequtive spatial datasets

#'

#' @param object_list a list of VoltRon (or Seurat) objects

#' @param reference_spatdata a reference spatial data set, used only if \code{object_list} is \code{NULL}

#' @param query_spatdata a query spatial data set, used only if \code{object_list} is \code{NULL}

#' @param keypoints (DEPRECATED) a list of tables, each points to matching keypoints from registered images.

#' @param mapping_parameters for manual image registration, a list of tables, each points to matching keypoints from registered images, and for automated image registration, a set of mapping parameters

#' @param interactive if TRUE, the shiny application for image registration will be triggered, otherwise 'mapping_parameters' or 'keypoints' should be defined.

#' @param shiny.options a list of shiny options (launch.browser, host, port etc.) passed \code{options} arguement of \link{shinyApp}. For more information, see \link{runApp}

#'

#' @import shiny

#' @importFrom shinyjs useShinyjs show hide

#' @importFrom stats median

#' @importFrom magick image_read

#'

#' @export

registerSpatialData <- function(object_list = NULL, reference_spatdata = NULL, query_spatdata = NULL, keypoints = NULL, mapping_parameters = list(), interactive = TRUE,

                                shiny.options = list(launch.browser = getOption("shiny.launch.browser", interactive()))) {

  ## Importing images ####

  # if the input is not a list, switch to reference vs query mode

  if(!is.null(object_list)){

    spatdata_list <- object_list

    centre <- floor(stats::median(seq_len(length(spatdata_list))))

    register_ind <- setdiff(seq_len(length(spatdata_list)), centre)

  } else {

    spatdata_list <- list(reference_spatdata, query_spatdata)

    centre <- 1

    register_ind <- 2

  }

  # get images from the list of objects

  orig_image_query_list_full <- lapply(spatdata_list, function(spat){

    assayname <- vrAssayNames(spat)

    channel_names <- vrImageChannelNames(spat[[assayname]])

    sapply(channel_names, function(chan){

      img <- vrImages(spat[[assayname]], channel = chan, as.raster = TRUE)

      if(!inherits(img, "Image_Array")){

        img <- magick::image_read(img)

      }

      img

    }, USE.NAMES = TRUE)

  })

  orig_image_query_list <- lapply(orig_image_query_list_full, function(spat_img) {

    return(spat_img[[1]])

  })

  orig_image_channelname_list <- lapply(spatdata_list, function(spat){

    assayname <- vrAssayNames(spat)

    vrImageChannelNames(spat[[assayname]])

  })

  ## Parameters ####

  if(!is.null(keypoints)){

    message("The use of 'keypoints' is deprecated, please use 'mapping_parameters' instead!")

    mapping_parameters[["keypoints"]] <- keypoints

  }

  if(!"keypoints" %in% names(mapping_parameters) && !all(is.null(names(mapping_parameters)))){

    if(all(grepl("[0-9]-[0-9]", names(mapping_parameters)))){

      mapping_parameters[["keypoints"]] <- mapping_parameters

    } else {

      stop("'mapping_parameters' does not include keypoints")

    }

  }

  ## Non-interactive Registration ####

  if(!interactive){

    return(getNonInteractiveRegistration(obj_list = spatdata_list, 

                                         centre = centre, 

                                         register_ind = register_ind, 

                                         mapping_parameters = mapping_parameters, 

                                         image_list = orig_image_query_list,

                                         image_list_full = orig_image_query_list_full,

                                         channel_names = orig_image_channelname_list))

  }

  ## UI and Server ####

  ui <- fluidPage(

    # use javascript extensions for Shiny

    shinyjs::useShinyjs(),

    # side bar

    sidebarLayout(position = "left",

                  # Side bar

                  sidebarPanel(

                    tags$style(make_css(list('.well', 'margin', '7%'))),

                    # # specific settings for dealing with simultaneous click and brush events

                    # # https://jokergoo.github.io/2021/02/20/differentiate-brush-and-click-event-in-shiny/

                    tags$script(HTML("

                        $('#plot').mousedown(function(e) {

                            var parentOffset = $(this).offset();

                            var relX = e.pageX - parentOffset.left;

                            var relY = e.pageY - parentOffset.top;

                            Shiny.setInputValue('x1', relX);

                            Shiny.setInputValue('y1', relY);

                        }).mouseup(function(e) {

                            var parentOffset = $(this).offset();

                            var relX = e.pageX - parentOffset.left;

                            var relY = e.pageY - parentOffset.top;

                            Shiny.setInputValue('x2', relX);

                            Shiny.setInputValue('y2', relY);

                            Shiny.setInputValue('action', Math.random());

                        });

                    ")),

                    # side bar for configuration

                    getSideBar(params = mapping_parameters),

                    # panel options

                    width = 3,

                  ),

                  mainPanel(

                    # Interface for the reference image

                    br(),

                    column(6,

                           # Reference Images

                           getImageTabPanels(length(orig_image_query_list), 

                                             orig_image_channelname_list, 

                                             type = "ref", 

                                             params = mapping_parameters),

                           br(),

                           # Matching Alignment

                           getAlignmentTabPanel(length(orig_image_query_list), centre, register_ind),

                    ),

                    # Interface for the query images

                    column(6,

                           # Query Images

                           getImageTabPanels(length(orig_image_query_list), 

                                             orig_image_channelname_list, 

                                             type = "query", 

                                             params = mapping_parameters),

                           br(),

                           # Registered Query Images

                           getRegisteredImageTabPanels(length(orig_image_query_list), 

                                                       centre, 

                                                       register_ind)

                    ),

                    # panel options

                    width = 9

                  )

    )

  )

  server <- function(input, output, session) {

    ## Manage interface ####

    updateParameterPanels(length(orig_image_query_list), mapping_parameters, input, output, session)

    updateTabPanels(centre, register_ind, input, output, session)

    # initiateParameterPanels(mapping_parameters, length(orig_image_query_list), input, output, session)

    ## Transform images ####

    trans_image_query_list <- transformImageQueryList(orig_image_query_list, input)

    ## get image and zoom info ####

    orig_image_query_info_list <- getImageInfoList(orig_image_query_list)

    zoom_list <- initiateZoomOptions(orig_image_query_info_list)

    manageImageZoomOptions(centre, register_ind, zoom_list, orig_image_query_list, orig_image_query_info_list, input, output, session)

    ## Manage reference and query keypoints ####

    # xyTable_list <- initateKeypoints(length(orig_image_query_list), keypoints)

    xyTable_list <- initateKeypoints(length(orig_image_query_list), mapping_parameters$keypoints)

    manageKeypoints(centre, register_ind, xyTable_list, orig_image_query_list, orig_image_query_info_list, zoom_list, input, output, session)

    ## Image registration ####

    registration_mapping_list <- initiateMappings(length(spatdata_list))

    getManualRegisteration(registration_mapping_list, spatdata_list, orig_image_query_list, xyTable_list,

                           centre, register_ind, input, output, session)

    getAutomatedRegisteration(registration_mapping_list, spatdata_list, orig_image_query_list_full, orig_image_channelname_list,

                              centre, register_ind, input, output, session)

    ## Main observable ####

    observe({

      # output the list of query images

      getImageOutput(orig_image_query_list_full, orig_image_query_info_list, xyTable_list, zoom_list, centre, input, output, session)

    })

    ## Return values for the shiny app ####

    observeEvent(input$done, {

      # keypoints and mapping

      keypoints <- reactiveValuesToList(xyTable_list)

      mapping <- reactiveValuesToList(registration_mapping_list)

      # mapping parameters

      mapping_parameters <- transferParameterInput(input, 

                                                   image_list = orig_image_query_list)

      # get keypoints and registered spatial datasets

      stopApp(

        list(keypoints = keypoints,

             mapping_parameters = c(as.list(mapping_parameters), 

                                    list(keypoints = keypoints, 

                                         mapping = mapping)),

             registered_spat = getRegisteredObject(spatdata_list,

                                                   registration_mapping_list,

                                                   register_ind,

                                                   centre,

                                                   input,

                                                   reg_mode = ifelse(input$automatictag, "auto", "manual"),

                                                   image_list = orig_image_query_list))

      )

    })

  }

  # configure options

  shiny.options <- configure_shiny_options(shiny.options)

  # run app

  shiny::runApp(

    shiny::shinyApp(ui, server, options = list(host = shiny.options[["host"]], port = shiny.options[["port"]], launch.browser = shiny.options[["launch.browser"]]),

                    onStart = function() {

                      onStop(function() {

                      })

                    })

  )

}

####

# User Interface ####

####

#' getSideBar

#'

#' The UI for the app side bar

#'

#' @param params mapping parameters

#' 

#' @import shiny

#' 

#' @noRd

getSideBar <- function(params = NULL){

  list(

    h4("Spatial Data Alignment"),

    fluidRow(

      column(12,shiny::checkboxInput("automatictag", "Automated", value = params[["automatictag"]])),

      br(),

      column(12,selectInput("Method", "Method", 

                            choices = c("Homography", "Non-Rigid", "Homography + Non-Rigid"), 

                            # selected = "Homography")),

                            selected = ifelse(is.null(params[["Method"]]), "Homography", params[["Method"]]))),

      br(),

      column(12,selectInput("Matcher", "Matcher", 

                            choices = c("FLANN", "BRUTE-FORCE"), 

                            # selected = "FLANN")),

                            selected = ifelse(is.null(params[["Matcher"]]), "FLANN", params[["Matcher"]]))),

      br(),

      column(12,textInput("GOOD_MATCH_PERCENT", "Match %", 

                          # value = "0.20", 

                          value = ifelse(is.null(params[["GOOD_MATCH_PERCENT"]]), "0.20", params[["GOOD_MATCH_PERCENT"]]),

                          width = "80%", placeholder = NULL)),

      column(12,textInput("MAX_FEATURES", "# of Features", 

                          # value = "1000", 

                          value = ifelse(is.null(params[["MAX_FEATURES"]]), "1000", params[["MAX_FEATURES"]]),

                          width = "80%", placeholder = NULL)),

      br(),

      column(12,shiny::actionButton("register", "Register!")),

      br(),

    ),

    br(),

    fluidRow(

      column(12,shiny::htmlOutput("summary"))

    ),

    br(),

    fluidRow(

      column(12,shiny::actionButton("done", "Done")),

      br()

    ),

    br(),

    h4("How to use"),

    p(style="font-size: 12px;", strong("Single-L-click:"), "Select point"),

    p(style="font-size: 12px;", strong("Single-L-hold-drag:"), "Select area"),

    p(style="font-size: 12px;", strong("Double-L-click (selected area):"), "Zoom in"),

    p(style="font-size: 12px;", strong("Double-L-click (no area):"), "Zoom out")

  )

}

#' getImageTabPanels

#'

#' The UI for a set of reference/query spatial slides

#'

#' @param len_images the number of query images

#' @param channel_names the list of channel names for each image

#' @param type Either reference (ref) or query (query) image

#' @param params mapping parameters

#'

#' @noRd

getImageTabPanels <- function(len_images, channel_names, type, params = NULL){

  # get panel label

  label <- ifelse(type == "ref", "Ref. ", "Query ")

  # call panels

  do.call(tabsetPanel, c(id=paste0('image_tab_panel_',type), lapply(seq_len(len_images), function(i) {

    tabPanel(paste0(label,i),

             br(),

             fluidRow(

               column(4, selectInput(paste0("rotate_", type, "_image",i), 

                                     "Rotate (ClockWise):", 

                                     choices = c(0,90,180,270), 

                                     # selected = 0)),

                                     selected = ifelse(is.null(params[[paste0("rotate_", type, "_image",i)]]), 0, params[[paste0("rotate_", type, "_image",i)]]))),

               column(4, selectInput(paste0("flipflop_", type, "_image",i), 

                                     "Transform:", 

                                     choices = c("None", "Flip", "Flop"), 

                                     # selected = "None")),

                                     selected = ifelse(is.null(params[[paste0("flipflop_", type, "_image",i)]]), "None", params[[paste0("flipflop_", type, "_image",i)]]))),

               column(4, selectInput(paste0("negate_", type, "_image",i), 

                                     "Negate Image:", 

                                     choices = c("No", "Yes"), 

                                     # selected = "No"))

                                     selected = ifelse(is.null(params[[paste0("negate_", type, "_image",i)]]), "No", params[[paste0("negate_", type, "_image",i)]])))

             ),

             fluidRow(

               column(4, selectInput(paste0("channel_", type, "_image",i), 

                                     "Channel:", 

                                     choices = channel_names[[i]])),

               column(4, sliderInput(paste0("scale_", type, "_image",i), 

                                     "Scale Parameter", 

                                     min = 0, 

                                     max = 1,  

                                     # value = 1)),

                                     value = ifelse(is.null(params[[paste0("scale_", type, "_image",i)]]), "1", params[[paste0("scale_", type, "_image",i)]]))),

               textOutput(paste0("scaleinfo_", type, "_image",i))

             ),

             fluidRow(imageOutput(paste0("plot_", type, i), 

                                  click = paste0("click_plot_", type, i),

                                  dblclick = paste0("dblclick_plot_", type, i),

                                  brush = brushOpts(paste0("brush_plot_", type, i), fill = "green", resetOnNew = TRUE))),

             br(),

             fluidRow(

               shiny::actionButton(paste0("remove_", type, i), "Remove Point")

             ),

    )

  })))

}

#' getRegisteredImageTabPanels

#'

#' The UI for a set of query spatial slides

#'

#' @param len_images the number of query images

#' @param centre center image index

#' @param register_ind query image indices

#'

#' @noRd

getAlignmentTabPanel <- function(len_images, centre, register_ind){

  # tab panels

  do.call(tabsetPanel, c(id='image_tab_panel_alignment',lapply(register_ind, function(i) {

    tabPanel(paste0("Ali. ",i, "->", centre),

             br(),

             fluidRow(imageOutput(paste0("plot_alignment",i)))

    )

  })))

}

#' getRegisteredImageTabPanels

#'

#' The UI for a set of query spatial slides

#'

#' @param len_images the number of query images

#' @param centre center image index

#' @param register_ind query image indices

#'

#' @return tabsetpanel

#'

#' @noRd

getRegisteredImageTabPanels <- function(len_images, centre, register_ind){

  # tab panels

  do.call(tabsetPanel, c(id='image_tab_panel_reg_query',lapply(register_ind, function(i) {

    tabPanel(paste0("Reg. ",i, "->", centre),

             br(),

             fluidRow(

               column(12, align="center",

                      imageOutput(paste0("plot_query_reg",i))

               )

             )

    )

  })))

}

#' updateTabPanels

#'

#' A function for automatized selection of reference/query tab panels

#'

#' @param centre center image index

#' @param register_ind query image indices

#' @param input input

#' @param output output

#' @param session session

#'

#' @noRd

updateTabPanels <- function(centre, register_ind, input, output, session){

  # number of panels

  npanels <- length(register_ind) + 1

  # observe changes in the reference tab panel

  observeEvent(input$image_tab_panel_ref,{

    selected_panel <- input$image_tab_panel_ref

    selected_panel_ind <- as.numeric(strsplit(selected_panel, split = " ")[[1]][2])

    query_panel_ind <- (selected_panel_ind + 1)

    if(query_panel_ind == 1) query_panel_ind <- npanels

    updateTabsetPanel(session, "image_tab_panel_query", paste0("Query ", query_panel_ind))

    updateTabsetPanel(session, "image_tab_panel_reg_query", paste0("Reg. ",selected_panel_ind, "->", centre))

    if(selected_panel_ind == npanels)

      updateTabsetPanel(session, "image_tab_panel_ref", paste0("Ref. ", selected_panel_ind-1))

  })

  # observe changes in the query tab panel

  observeEvent(input$image_tab_panel_query,{

    selected_panel <- input$image_tab_panel_query

    selected_panel_ind <- as.numeric(strsplit(selected_panel, split = " ")[[1]][2])

    query_panel_ind <- (selected_panel_ind - 1)

    if(query_panel_ind == 0) query_panel_ind <- 1

    updateTabsetPanel(session, "image_tab_panel_ref", paste0("Ref. ", query_panel_ind))

    if(selected_panel_ind == 1){

      updateTabsetPanel(session, "image_tab_panel_query", paste0("Query ", selected_panel_ind+1))

      updateTabsetPanel(session, "image_tab_panel_reg_query", paste0("Reg. ",selected_panel_ind+1, "->", centre))

    } else {

      query_panel_ind <- selected_panel_ind

      updateTabsetPanel(session, "image_tab_panel_reg_query", paste0("Reg. ",query_panel_ind, "->", centre))

    }

  })

  # observe changes in the registered query tab panel

  observeEvent(input$image_tab_panel_reg_query,{

    selected_panel <- input$image_tab_panel_reg_query

    selected_panel_ind <- strsplit(selected_panel, split = " ")[[1]][2]

    selected_panel_ind <- as.numeric(strsplit(selected_panel_ind, split = "->")[[1]][1])

    updateTabsetPanel(session, "image_tab_panel_query", paste0("Query ", selected_panel_ind))

    selected_panel_ali <- gsub("Reg.", "Ali.", selected_panel)

    updateTabsetPanel(session, "image_tab_panel_alignment", selected_panel_ali)

  })

  # observe changes in the registered query tab panel

  observeEvent(input$image_tab_panel_alignment,{

    selected_panel <- input$image_tab_panel_alignment

    selected_panel_reg <- gsub("Ali.", "Reg.", selected_panel)

    updateTabsetPanel(session, "image_tab_panel_reg_query", selected_panel_reg)

  })

}

#' updateParameterPanels

#'

#' A function for managing which parameter panels or input boxes to appear on UI

#'

#' @param len_images the length of images

#' @param params mapping parameters

#' @param input input

#' @param output output

#' @param session session

#' 

#' @importFrom shinyjs hide show

#' @import shiny

#'

#' @noRd

updateParameterPanels <- function(len_images, params, input, output, session){

  # done event

  shinyjs::hide(id = "done")

  observeEvent(input$register, {

    shinyjs::show(id = "done")

  })

  # registration panels/buttons

  shinyjs::hide(id = "GOOD_MATCH_PERCENT")

  shinyjs::hide(id = "MAX_FEATURES")

  # hide scale parameters

  for(i in seq_len(len_images)){

    shinyjs::hide(id = paste0("scale_ref_image",i))

    shinyjs::hide(id = paste0("scale_query_image",i))

    shinyjs::hide(id = paste0("scaleinfo_ref_image",i))

    shinyjs::hide(id = paste0("scaleinfo_query_image",i))

  }

  observeEvent(input$automatictag, {

    if(input$automatictag){

      # Method and Matcher

      choices <- c("Homography", "Homography + Non-Rigid")

      selected <- ifelse(is.null(params[["Method"]]), choices[1],

                         ifelse(!params[["Method"]] %in% choices, choices[1], params[["Method"]]))

      # selected <- choices[1]

      updateSelectInput(session, 

                        "Method", 

                        choices = choices, 

                        # selected = "Homography")

                        selected = selected)

      shinyjs::show(id = "Matcher")

      # show automatic registration parameters of BRUTE-FORCE

      if(input$Matcher == "BRUTE-FORCE"){

        shinyjs::show(id = "GOOD_MATCH_PERCENT")

        shinyjs::show(id = "MAX_FEATURES")

      } 

      if(input$Matcher == "FLANN"){

        shinyjs::hide(id = "GOOD_MATCH_PERCENT")

        shinyjs::hide(id = "MAX_FEATURES")

      }

      # show scale parameters

      for(i in seq_len(len_images)){

        shinyjs::show(id = paste0("scale_ref_image",i))

        shinyjs::show(id = paste0("scale_query_image",i))

        shinyjs::show(id = paste0("scaleinfo_ref_image",i))

        shinyjs::show(id = paste0("scaleinfo_query_image",i))

      }

    } else {

      # Method and Matcher

      choices <- c("Non-Rigid", "Homography + Non-Rigid")

      selected <- ifelse(is.null(params[["Method"]]), choices[1],

                         ifelse(!params[["Method"]] %in% choices, choices[1], params[["Method"]]))

      # selected <- choices[1]

      updateSelectInput(session, "Method", 

                        choices = choices, 

                        # selected = "Non-Rigid")

                        selected = selected)

      shinyjs::hide(id = "Matcher")

      # hide automatic registration parameters of BRUTE-FORCE

      if(input$Matcher == "FLANN"){

        shinyjs::hide(id = "GOOD_MATCH_PERCENT")

        shinyjs::hide(id = "MAX_FEATURES")

      }

      # hide scale parameters

      for(i in seq_len(len_images)){

        shinyjs::hide(id = paste0("scale_ref_image",i))

        shinyjs::hide(id = paste0("scale_query_image",i))

        shinyjs::hide(id = paste0("scaleinfo_ref_image",i))

        shinyjs::hide(id = paste0("scaleinfo_query_image",i))

      }

    }

  })

  observeEvent(input$Method, {

    if(grepl("FLANN", input$Matcher)){

      shinyjs::hide(id = "GOOD_MATCH_PERCENT")

      shinyjs::hide(id = "MAX_FEATURES")

    } else {

      shinyjs::show(id = "GOOD_MATCH_PERCENT")

      shinyjs::show(id = "MAX_FEATURES")

      if(grepl("Non-Rigid", input$Method)){

        updateSelectInput(session, "Method", selected = "Homography") 

        showNotification("Brute-Force Matching can't be used with Non-Rigid Registration\n")

      }

    }

  })

  observeEvent(input$Matcher, {

    if(grepl("FLANN", input$Matcher)){

      shinyjs::hide(id = "GOOD_MATCH_PERCENT")

      shinyjs::hide(id = "MAX_FEATURES")

    } else {

      shinyjs::show(id = "GOOD_MATCH_PERCENT")

      shinyjs::show(id = "MAX_FEATURES")

      if(grepl("Non-Rigid", input$Method)){

        updateSelectInput(session, "Method", selected = "Homography") 

        showNotification("Brute-Force Matching can't be used with Non-Rigid Registration\n")

      }

    }

  })

}

#' initiateParameterPanels

#'

#' A function for managing which initialized parameters

#'

#' @param mapping_parameters mapping parameters

#' @param len_images the length of images

#' @param input input

#' @param output output

#' @param session session

#' 

#' @import shiny

#'

#' @noRd

initiateParameterPanels <- function(mapping_parameters, len_images, input, output, session){

  # update image specific parameters

  lapply(c("ref", "query"), function(t){

    lapply(seq_len(len_images), function(i){

      lapply(c("rotate", "flipflop", "negate", "channel"), function(c){

          updateSelectInput(session = session, paste0(c, "_", t, "_image",i), selected = mapping_parameters[[paste0(c, "_", t, "_image",i)]])

      })

      updateSliderInput(session = session, paste0("scale_", t, "_image",i), value = mapping_parameters[[paste0("scale_", t, "_image",i)]])

    })

  })

  # update alignment parameters

  updateCheckboxInput(session = session, "automatictag", value = mapping_parameters[["automatictag"]])

  updateTextInput(session = session, "GOOD_MATCH_PERCENT", value = mapping_parameters[["GOOD_MATCH_PERCENT"]])

  updateTextInput(session = session, "MAX_FEATURES", value = mapping_parameters[["MAX_FEATURES"]])

  updateSelectInput(session = session, "Method", selected = mapping_parameters[["Method"]])

  updateSelectInput(session = session, "Matcher", selected = mapping_parameters[["Matcher"]])

}

####

# Registering Objects ####

####

#' getRegisteredObject

#'

#' Get registered list of VoltRon objects

#'

#' @param obj_list a list of VoltRon objects

#' @param mapping_list a list of transformation matrices

#' @param register_ind the indices of query images/spatialdatasets

#' @param centre the index of the central reference image/spatialdata

#' @param input input

#' @param reg_mode the registration mode, either "auto" or "manual"

#' @param image_list the list of query/ref images

#' @param aligned_image_list the list of aligned query/ref images

#'

#' @noRd

getRegisteredObject <- function(obj_list, mapping_list, register_ind, centre, input, reg_mode = "manual", image_list = NULL, aligned_image_list = NULL){

  # initiate registered VoltRon objects

  ref_ind <- centre

  registered_sr <- list()

  # the original reference object

  registered_sr[[ref_ind]] <- obj_list[[ref_ind]]

  # waiter start

  withProgress(message = 'Register Coordinates (and Segments)', value = 0, {

    # register all assays

    for(i in register_ind){

      # choose image query and ref order

      if(i > ref_ind){

        ref_extension = paste0("ref_image",ref_ind)

        query_extension = paste0("query_image",i)

      } else {

        ref_extension = paste0("query_image",ref_ind)

        query_extension = paste0("ref_image",i)

      }

      # register the VoltRon object

      for(assy in vrAssayNames(obj_list[[i]], assay = "all")){

        # Increment the progress bar, and update the detail text.

        incProgress(1/length(register_ind), detail = paste("Register", assy, "of Layer", i, sep = " "))

        # register assay

        obj_list[[i]] <- applyPerspectiveTransform(obj_list[[i]],

                                                   assay = assy,

                                                   mapping = mapping_list[[paste0(i)]],

                                                   reference_image = image_list[[ref_ind]],

                                                   input = input,

                                                   reg_mode = reg_mode,

                                                   ref_extension = ref_extension,

                                                   query_extension = query_extension)

      }

      registered_sr[[i]] <- obj_list[[i]]

    }

  })

  return(registered_sr)

}

#' getRegisteredObjectNonShiny

#'

#' Get registered list of VoltRon objects, without shiny

#'

#' @param obj_list a list of VoltRon objects

#' @param mapping_list a list of transformation matrices

#' @param register_ind the indices of query images/spatialdatasets

#' @param centre the index of the central reference image/spatialdata

#' @param input input

#' @param reg_mode the registration mode, either "auto" or "manual"

#' @param image_list the list of query/ref images

#' @param aligned_image_list the list of aligned query/ref images

#'

#' @noRd

getRegisteredObjectNonShiny <- function(obj_list, mapping_list, register_ind, centre, input, reg_mode = "manual", image_list = NULL, aligned_image_list = NULL){

  # initiate registered VoltRon objects

  ref_ind <- centre

  registered_sr <- list()

  # the original reference object

  registered_sr[[ref_ind]] <- obj_list[[ref_ind]]

  # message

  message('Register Coordinates (and Segments)')

  # register all assays

  for(i in register_ind){

    # choose image query and ref order

    if(i > ref_ind){

      ref_extension = paste0("ref_image",ref_ind)

      query_extension = paste0("query_image",i)

    } else {

      ref_extension = paste0("query_image",ref_ind)

      query_extension = paste0("ref_image",i)

    }

    # register the VoltRon object

    for(assy in vrAssayNames(obj_list[[i]], assay = "all")){

      # message

      message("Register ", assy, " of Layer ", i)

      # register assay

      obj_list[[i]] <- applyPerspectiveTransform(obj_list[[i]],

                                                 assay = assy,

                                                 mapping = mapping_list[[paste0(i)]],

                                                 reference_image = image_list[[ref_ind]],

                                                 input = input,

                                                 reg_mode = reg_mode,

                                                 ref_extension = ref_extension,

                                                 query_extension = query_extension)

    }

    registered_sr[[i]] <- obj_list[[i]]

  }

  return(registered_sr)

}

#' applyPerspectiveTransform

#'

#' Applying a perspective transformation to the VoltRon object

#'

#' @param object a VoltRon objects

#' @param mapping a list of transformation matrices

#' @param reference_image the reference image

#' @param input input

#' @param reg_mode the registration mode, either "auto" or "manual"

#' @param ref_extension the shiny extension of reference image

#' @param query_extension the shiny extension of query image

#'

#' @importFrom magick image_info

#'

#' @noRd

applyPerspectiveTransform <- function(object,

                                      assay = NULL,

                                      mapping,

                                      reference_image,

                                      input,

                                      reg_mode,

                                      ref_extension,

                                      query_extension){

  # check assay

  if(is.null(assay))

    assay <- vrAssayNames(object)

  # get coordinates, segments and spatial points

  coords <- vrCoordinates(object, assay = assay)

  segments <- vrSegments(object, assay = assay)

  if(reg_mode == "manual"){

    # get the multiplication of all homography matrices

    # cur_mapping <- Reduce("%*%", mapping)

    mapping <- manageMapping(mapping)

    # get registered coordinates

    coords_reg <- as.matrix(as(coords, "dgCMatrix"))

    coords_reg[,c("x", "y")] <- applyMapping(coords[,c("x", "y")], mapping)

    rownames(coords_reg) <- rownames(coords)

    colnames(coords_reg) <- colnames(coords)

    # get registered segments

    if(length(segments) > 0){

      segments_reg <- do.call(rbind, segments)

      segments_reg[,colnames(segments_reg) %in% c("x", "y")] <- applyMapping(as.matrix(segments_reg[,colnames(segments_reg) %in% c("x", "y")]), mapping)

      segments_reg <- split(segments_reg, segments_reg[,1])

      names(segments_reg) <- names(segments)

    } else {

      segments_reg <- segments

    }

    # get registered image (including all channels)

    image_reg_list <- sapply(vrImageChannelNames(object[[assay]]), function(x) NULL, USE.NAMES = TRUE)

    for(channel_ind in names(image_reg_list)){

      query_image <- vrImages(object[[assay]], channel = channel_ind, as.raster = TRUE)

      if(!inherits(query_image, "Image_Array")){

        query_image <- magick::image_read(query_image)

      }

      warped_image <- getRcppWarpImage(ref_image = reference_image,

                                       query_image = query_image,

                                       mapping = mapping)

      image_reg_list[[channel_ind]] <- warped_image

    }

  } else if(reg_mode == "auto"){

    # get the multiplication of all homography matrices

    mapping <- manageMapping(mapping)

    # images

    ref_image <- transformImage(reference_image, ref_extension, input)

    query_image <- vrImages(object[[assay]], as.raster = TRUE)

    if(!inherits(query_image, "Image_Array")){

      query_image <- magick::image_read(query_image)

    }

    query_image <- transformImage(query_image, query_extension, input)

    # image info

    query_info <- getImageInfo(query_image)

    ref_info <- getImageInfo(ref_image)

    # get registered coordinates

    coords_reg <- as.data.frame(as.matrix(as(coords, "dgCMatrix")))

    coords_reg <- transformImageKeypoints(query_image, coords_reg[,c("x","y")], query_extension, input)$keypoints

    coords_reg[,2] <- query_info$height - coords_reg[,2]

    coords_reg <- as.matrix(coords_reg)

    coords_reg <- applyMapping(coords_reg, mapping)

    coords_reg <- as.data.frame(coords_reg)

    coords_reg[,2] <- ref_info$height - coords_reg[,2]

    colnames(coords_reg) <- c("x", "y")

    coords_reg <- transformKeypoints(ref_image, coords_reg, ref_extension, input)

    coords_reg <- as.matrix(coords_reg)

    rownames(coords_reg) <- rownames(coords)

    # fix 3rd dimension 

    coords[,c("x", "y")] <- coords_reg[,c("x", "y")]

    coords_reg <- coords

    # get registered segments

    if(length(segments) > 0){

      segments_reg <- do.call(rbind, segments)

      segments_reg <- as.data.frame(segments_reg)

      segments_reg <- transformImageKeypoints(query_image, segments_reg, query_extension, input)$keypoints

      segments_reg[,colnames(segments_reg) %in% c("y")] <- query_info$height - segments_reg[,colnames(segments_reg) %in% c("y")]

      segments_reg[,colnames(segments_reg) %in% c("x", "y")] <- applyMapping(as.matrix(segments_reg[,colnames(segments_reg) %in% c("x", "y")]), mapping)

      segments_reg[,colnames(segments_reg) %in% c("y")]  <- ref_info$height - segments_reg[,colnames(segments_reg) %in% c("y")]

      segments_reg <- transformKeypoints(ref_image, segments_reg, ref_extension, input)

      segments_reg <- split(segments_reg, segments_reg[,1])

      names(segments_reg) <- names(segments)

    } else {

      segments_reg <- segments

    }

    # get registered image (including all channels)

    image_reg_list <- sapply(vrImageChannelNames(object[[assay]]), function(x) NULL, USE.NAMES = TRUE)

    for(channel_ind in names(image_reg_list)){

      # rotate, flip and flop before warping in C++

      ref_image <- transformImage(reference_image, ref_extension, input)

      query_image <- vrImages(object[[assay]], channel = channel_ind, as.raster = TRUE)

      if(!inherits(query_image, "Image_Array")){

        query_image <- magick::image_read(query_image)

      }

      query_image <- transformImage(query_image, query_extension, input)

      query_image <- getRcppWarpImage(ref_image, query_image, mapping = mapping)

      query_image <- transformImageReverse(query_image, ref_extension, input)

      image_reg_list[[channel_ind]] <- query_image

    }

  }

  # make new image object

  vrImages(object[[assay]], reg = TRUE) <- formImage(coords = coords_reg, segments = segments_reg, image = image_reg_list)

  # set up the spatial coordinate name 

  vrMainSpatial(object[[assay]]) <- paste0(vrMainSpatial(object[[assay]]), "_reg")

  # return object

  return(object)

}

####

# Managing Mappings ####

####

manageMapping <- function(mappings){

  # check if all transformations are homography

  allHomography <- suppressWarnings(all(lapply(mappings, function(map){

    nrow(map[[1]] > 0) && is.null(map[[2]])

  })))

  # change the mapping

  new_mappings <- list()

  if(allHomography){

    mappings <- lapply(mappings, function(map) map[[1]])

    new_mappings <- list(

      list(Reduce("%*%", mappings),

           NULL)

    )

  } else {

    new_mappings <- mappings

  }

  # return

  return(new_mappings)

}

####

# Managing Parameters ####

####

#' initateKeypoints

#'

#' Initiate shiny reactive values for keypoint dataframes for pairwise reference and query images

#'

#' @param len_images the length of images

#' @param keypoints_list the list of keypoint pairs

#' @param input shiny input

#' @param output shiny output

#' @param session shiny session

#'

#' @importFrom dplyr tibble

#'

#' @noRd

initateKeypoints <- function(len_images, keypoints_list, input, output, session){

  # initiate keypoints

  if(is.null(keypoints_list)){

    keypoints_list <- lapply(seq_len(len_images-1), function(i) {

      list(ref = dplyr::tibble(KeyPoint = numeric(), x = numeric(), y = numeric()),

           query = dplyr::tibble(KeyPoint = numeric(), x = numeric(), y = numeric()))

    })

    # set names for keypoints

    names(keypoints_list) <- paste0(seq_len(len_images-1),"-",2:len_images)

  }

  # return keypoints as reactive values

  do.call("reactiveValues", keypoints_list)

}

#' manageKeypoints

#'

#' A list of shiny observe events for tables and auxiliary operations for pairwise reference and query image

#'

#' @param centre center image index

#' @param register_ind query image indices

#' @param xyTable_list a list of keypoints x,y coordinates for each magick image

#' @param image_list a lost of magick image

#' @param info_list a list of magick image info on width and height

#' @param zoom_list a list of x,y ranges of query and ref images

#' @param input shiny input

#' @param output shiny output

#' @param session shiny session

#'

#' @noRd

manageKeypoints <- function(centre, register_ind, xyTable_list, image_list, info_list, zoom_list, input, output, session){

  # get image types

  image_types <- c("ref","query")

  # get the length of tables

  len_tables <- length(xyTable_list)

  # set click operations for reference and query points

  lapply(seq_len(len_tables), function(i){

    lapply(image_types, function(type){

      # listen to click operations for reference/query plots

      observeEvent(input[[paste0("click_plot_", type ,i)]], {

        # get brush information

        brush <- input[[paste0("brush_plot_", type ,i)]]

        limits <- cbind(zoom_list[[paste0(i)]][[type]]$x, zoom_list[[paste0(i)]][[type]]$y)

        if (is.null(brush)) {

          # get image

          image <- image_list[[i]]

          # get and transform keypoints

          keypoint <- data.frame(x = input[[paste0("click_plot_",type,i)]]$x,

                                 y = input[[paste0("click_plot_",type,i)]]$y)

          # get the transformed zoom info first and calculate width, then record transformed image

          limits_trans <- data.frame(x = limits[,1], y = limits[,2])

          limits_trans <- transformImageKeypoints(image, limits_trans, paste0(type, "_image",i), input)

          image_trans <- limits_trans$image

          limits_trans <- data.frame(x = range(limits_trans$keypoints[,1]), y = range(limits_trans$keypoints[,2]))

          # correct for scaling, scale factor = 1000

          width <- limits_trans[2,1]-limits_trans[1,1]

          height <- limits_trans[2,2]-limits_trans[1,2]

          if(max(height,width) > 1000){

            if(inherits(image_trans, "Image_Array")){

              n.series <- ImageArray::len(image_trans)

              cur_width <- width

              cur_height <- height

              for(ii in 2:n.series){

                cur_width <- width/(2^(ii-1))

                cur_height <- height/(2^(ii-1))

                if(max(cur_height, cur_width) <= 1000){

                  break

                }

              }

              keypoint <- keypoint*width/ceiling(cur_width)

            } else {

              keypoint <- keypoint*width/1000 

            }

          }

          # correct for zoom information

          keypoint <- keypoint + limits_trans[1,]

          # correct for flipflop and rotate

          keypoint <- transformKeypoints(image_trans, keypoint, paste0(type, "_image",i), input)

          # insert keypoint to associated table

          ref_ind <- ifelse(type == "ref", i, i-1) # select reference image

          # insert keypoint to associated table

          temp <- xyTable_list[[paste0(ref_ind, "-", ref_ind+1)]][[type]]

          temp <- temp %>%

            add_row(KeyPoint = nrow(temp)+1, x = keypoint$x, y = keypoint$y)

          xyTable_list[[paste0(ref_ind, "-", ref_ind+1)]][[type]] <- temp

        }

      })

    })

  })

  # remove keypoints from images

  lapply(seq_len(len_tables), function(i){

    lapply(image_types, function(type){

      observeEvent(input[[paste0("remove_", type, i)]], {

        ref_ind <- ifelse(type == "ref", i, i-1) # select reference image

        temp <- xyTable_list[[paste0(ref_ind, "-", ref_ind+1)]][[type]]

        if(nrow(temp) > 0){

          temp <- temp %>% filter(KeyPoint != nrow(temp))

          xyTable_list[[paste0(ref_ind, "-", ref_ind+1)]][[type]] <- temp

        }

      })

    })

  })

}

#' transformImageKeypoints

#'

#' Apply given transformations to a magick image and keypoints for plotting

#'

#' @param image magick image

#' @param extension name extension for the shiny input parameter

#' @param keypoints a set of keypoints

#' @param input shiny input

#' @param session shiny session

#'

#' @importFrom magick image_negate image_rotate image_flip image_flop image_info

#'

#' @noRd

transformImageKeypoints <- function(image, keypoints, extension, input, session){

  if(is.null(keypoints))

    return(list(image = image, keypoints = keypoints))

  # negate image

  input_negate <- input[[paste0("negate_", extension)]]

  if(input_negate == "Yes"){

    image <- negateImage(image)

  }

  # get unrotated image info

  image_limits <- unlist(getImageInfo(image)[1,c("width", "height")])

  image_origin <- image_limits/2

  # rotate image and keypoints

  input_rotate <- as.numeric(input[[paste0("rotate_", extension)]])

  image <- rotateImage(image, input_rotate)

  # get rotated image info

  rotated_image_limits <- unlist(getImageInfo(image)[1,c("width", "height")])

  rotated_image_origin <- rotated_image_limits/2

  # rotate keypoints

  keypoints <- rotateKeypoint(keypoints, input_rotate, image_origin, image_limits, rotated_image_origin, rotated_image_limits)

  # flip flop image and keypoints

  input_flipflop <- input[[paste0("flipflop_", extension)]]

  if(input_flipflop == "Flip"){

    # image <- magick::image_flip(image)

    image <- flipImage(image)

  } else if(input_flipflop == "Flop"){

    # image <- magick::image_flop(image)

    image <- flopImage(image)

  }

  # flipflop keypoints

  keypoints <- flipflopKeypoint(keypoints, rotated_image_limits, input_flipflop)

  # return both the image and the keypoints

  return(list(image = image, keypoints = keypoints))

}

#' transformKeypoints