--- a
+++ b/R/image.R
@@ -0,0 +1,1656 @@
+####
+# Create vrImage Object ####
+####
+
+#' formImage
+#'
+#' Create a vrImage (VoltRon image) object
+#'
+#' @param coords the coordinates of the spatial points
+#' @param segments the list of segments each associated with a spatial point
+#' @param image a singelton or list of images as magick-image objects
+#' @param main_channel the key of the main channel of vrImage object
+#'
+#' @importFrom magick image_data image_read image_info
+#' @importFrom methods new
+#'
+#' @export
+#'
+formImage <- function(coords, segments = list(), image = NULL, main_channel = NULL){
+
+  # get coordinates
+  if(inherits(coords, "data.frame")){
+    coords <- as.matrix(coords)
+  }
+  if(!inherits(coords, c("matrix", "dgCMatrix", "Matrix", "IterableMatrix"))){
+    stop("Coordinates table should either of a matrix or data.frame class!")
+  }
+  if(ncol(coords) == 2){
+    coords <- cbind(coords,0)
+    colnames(coords) <- c("x", "y", "z")
+  }
+  if(!ncol(coords) %in% c(2,3)){
+    stop("The length of colnames of the coordinates matrix should be either two or three!")
+  } 
+
+  # get segments
+  if(length(segments) > 0){
+    if(length(segments) == length(rownames(coords))){
+      names(segments) <- rownames(coords)
+    } else {
+      stop("Number of segments doesnt match the number of points!")
+    }
+  }
+
+  # check if the image input is a list
+  if(!is.null(image)){
+    if(is.list(image)){
+
+      # enter names if there are no names
+      if(is.null(names(image)))
+        names(image) <- paste("channel_", seq_len(length(image)), sep = "")
+
+      # get image information
+      imageinfo <- vapply(image, function(x) as.matrix(magick::image_info(x)[,c("width", "height")])[1,], 
+                          numeric(2), USE.NAMES = TRUE)
+      flag <- all(apply(imageinfo, 1, function(x) length(unique(x)) == 1))
+
+      #
+      if(!flag){
+        stop("When providing multiple images as channels, make sure that all images have the same dimensionality!")
+      } else {
+        image <- lapply(image, magick::image_data)
+        names(image) <- colnames(imageinfo)
+        if(is.null(main_channel))
+          main_channel <- names(image)[1]
+      }
+    } else {
+      image <- list(magick::image_data(image))
+      if(is.null(main_channel))
+        main_channel <- "channel_1"
+      names(image) <- main_channel
+    }
+  } else {
+    image <- list()
+    main_channel <- ""
+  }
+
+  # make vrimage object
+  methods::new("vrSpatial", coords = coords, segments = segments, image = image, main_channel = main_channel)
+}
+
+### Subset vrImage objects ####
+
+subsetvrImage <- function(x, subset, spatialpoints = NULL, image = NULL) {
+  
+  # start
+  object <- x
+  
+  if (!missing(x = subset)) {
+    subset <- rlang::enquo(arg = subset)
+  }
+  
+  # coords and segments
+  coords <- vrCoordinates(object)
+  segments <- vrSegments(object)
+  
+  if(!is.null(spatialpoints)){
+    
+    # check if spatial points are here
+    spatialpoints <- intersect(spatialpoints, rownames(coords))
+    if(length(spatialpoints) == 0){
+      return(NULL)
+    }
+    
+    # coordinates
+    vrCoordinates(object) <- coords[spatialpoints,, drop = FALSE]
+    
+    # segments
+    if(length(segments) > 0)
+      vrSegments(object) <- segments[spatialpoints]
+    
+  } else if(!is.null(image)) {
+    
+    # get one image
+    vrimage <- vrImages(object)
+    
+    # coordinates
+    cropped_coords <- subsetCoordinates(coords, vrimage, image)
+    vrCoordinates(object) <- cropped_coords
+    
+    # segments
+    cropped_segments <- segments[rownames(cropped_coords)]
+    if(length(segments) > 0){
+      segments[rownames(cropped_coords)] <- subsetSegments(cropped_segments, vrimage, image)
+      vrSegments(object) <- segments
+    }
+    
+    # spatial points
+    # object <- subset.vrImage(object, spatialpoints = rownames(cropped_coords))
+    object <- subsetvrImage(object, spatialpoints = rownames(cropped_coords))
+    
+    # image
+    for(img in vrImageChannelNames(object)){
+      
+      # check if the image is either ondisk or inmemory
+      img_data <- object@image[[img]]
+      if(inherits(img_data, "Image_Array")){
+        crop_info_int <- as.integer(strsplit(image, split = "[x|+]")[[1]])
+        img_data <- ImageArray::crop(img_data, ind = list(crop_info_int[3]:(crop_info_int[3]+crop_info_int[1]), crop_info_int[4]:(crop_info_int[4]+crop_info_int[2])))
+        object@image[[img]] <- img_data
+      } else {
+        img_data <- magick::image_read(img_data)
+        img_data <- magick::image_crop(img_data, image)
+        object@image[[img]] <- magick::image_data(img_data) 
+      }
+    }
+  }
+  
+  # set VoltRon class
+  return(object)
+}
+
+#' Subsetting vrImage objects
+#'
+#' Given a vrImage object, subset the object given one of the attributes.
+#'
+#' @param x A vrImage object
+#' @param subset Logical statement for subsetting
+#' @param spatialpoints the set of spatial points to subset the object
+#' @param image the subseting string passed to \link{image_crop}
+#'
+#' @method subset vrImage
+#' @order 5
+#'
+#' @importFrom rlang enquo
+#' @importFrom magick image_crop
+#'
+#' @export
+setMethod("subset", "vrImage", subsetvrImage)
+
+#' Subsetting vrSpatial objects
+#'
+#' Given a vrSpatial object, subset the object given one of the attributes.
+#'
+#' @param x A vrSpatial object
+#' @param subset Logical statement for subsetting
+#' @param spatialpoints the set of spatial points to subset the object
+#' @param image the subseting string passed to \link{image_crop}
+#'
+#' @method subset vrSpatial
+#' @order 5
+#'
+#' @importFrom rlang enquo
+#' @importFrom magick image_crop
+#'
+#' @export
+#'
+setMethod("subset", "vrSpatial", subsetvrImage)
+
+####
+# Methods ####
+####
+
+vrImagesVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, channel = NULL, as.raster = FALSE, scale.perc = 100){
+  
+  # get assay names
+  if(is.null(assay)){
+    assay_names <- vrAssayNames(object, assay = "all")
+  } else {
+    assay_names <- vrAssayNames(object, assay = assay)
+  }
+  
+  # get images
+  images <- sapply(assay_names, function(assy) vrImages(object[[assy]], 
+                                                        name = name, 
+                                                        reg = reg, 
+                                                        channel = channel,
+                                                        as.raster = as.raster, 
+                                                        scale.perc = scale.perc), USE.NAMES = TRUE)
+  if(length(images) == 1){
+    return(images[[1]])
+  } else {
+    return(images)
+  }
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#' @param name the name of the main spatial system
+#' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested
+#' @param channel the name of the channel associated with the image
+#' @param as.raster return as raster
+#' @param scale.perc scale percentage if lower resolution image needed
+#'
+#' @rdname vrImages
+#' @order 2
+#' @export
+setMethod("vrImages", "VoltRon", vrImagesVoltRon)
+
+vrImagesvrAssay <- function(object, name = NULL, reg = FALSE, channel = NULL, as.raster = FALSE, scale.perc = 100){
+  
+  # check image name
+  if(is.null(name)) {
+    name <- object@main_image
+  }
+  
+  # get registered image
+  if(reg){
+    if(!paste0(name, "_reg") %in% vrSpatialNames(object)){
+      warning("There are no registered images with name ", name, "!")
+    } else {
+      name <- paste0(name, "_reg")
+    }
+  }
+  
+  # check main image
+  if(!name %in% vrSpatialNames(object)){
+    stop(name, " is not among any image in this vrAssay object")
+  }
+  
+  return(vrImages(object@image[[name]], channel = channel, as.raster = as.raster, scale.perc = scale.perc))
+}
+
+#' @rdname vrImages
+#' @order 3
+#' @export
+setMethod("vrImages", "vrAssay", vrImagesvrAssay)
+
+#' @rdname vrImages
+#' @order 3
+#' @export
+setMethod("vrImages", "vrAssayV2", vrImagesvrAssay)
+
+vrImagesReplacevrAssay <- function(object, name = NULL, channel = NULL, reg = FALSE, value) {
+  if(is.null(name)) {
+    name <- object@main_image
+  }
+  
+  if(reg){
+    name <- paste0(name, "_reg")
+  }
+  
+  if(inherits(value, "vrImage") | inherits(value, "vrSpatial")){
+    object@image[[name]] <- value
+  } else {
+    if(!is.null(channel)){
+      vrImages(object@image[[name]], channel = channel) <- value
+    }
+  }
+  return(object)
+}
+
+#' @param value new image
+#' 
+#' @rdname vrImages
+#'
+#' @importFrom magick image_data
+#' @order 5
+#' @export
+setMethod("vrImages<-", "vrAssay", vrImagesReplacevrAssay)
+
+#' @param value new image
+#' 
+#' @rdname vrImages
+#'
+#' @importFrom magick image_data
+#' @order 5
+#' @export
+setMethod("vrImages<-", "vrAssayV2", vrImagesReplacevrAssay)
+
+vrImagesvrImage <- function(object, channel = NULL, as.raster = FALSE, scale.perc = 100){
+  
+  # check channels
+  if(is.null(channel)){
+    channel <- object@main_channel
+  } else {
+    if(!channel %in% vrImageChannelNames(object)){
+      warning("'", channel, "' is not among any channel in this vrImage object!")
+      return(NULL)
+    }
+  }
+  
+  # correct image scale
+  if(!is.numeric(scale.perc)){
+    stop("scale.perc should be between 0 and 1")
+  }
+  if(scale.perc <= 0 || scale.perc > 100){
+    stop("scale.perc should be between 0 and 100")
+  }
+  
+  # return image
+  if(channel!=""){
+    
+    # get image
+    img <- object@image[[channel]]
+    if(as.raster){
+      
+      # return raster image format
+      return(img)
+      
+    } else {
+      
+      # get image as array if image is stored as a DelayedArray
+      if(inherits(img, "Image_Array")){
+        # img <- as.array(img@seed)
+        img <- as.array(img)
+        img <- array(as.raw(img), dim = dim(img))
+      }
+      
+      # read image
+      img <- magick::image_read(img)
+      
+      # scale image if needed
+      if(scale.perc < 100){
+        img <- image_resize(img, geometry = magick::geometry_size_percent(scale.perc))
+      }
+      
+      # return regular image
+      return(img)
+    }
+  } else{
+    warning("No image was found!")
+    return(NULL)
+  }
+}
+
+#' @rdname vrImages
+#' @order 4
+#' @importFrom magick image_read geometry_size_percent
+#'
+#' @export
+setMethod("vrImages", "vrImage", vrImagesvrImage)
+
+#' @rdname vrImages
+#' @order 4
+#' @importFrom magick image_read geometry_size_percent
+#'
+#' @export
+setMethod("vrImages", "vrSpatial", vrImagesvrImage)
+
+vrImagesReplacevrImage <- function(object, channel = NULL, value){
+  
+  if(channel %in% vrImageChannelNames(object)){
+    warning("A channel with name '", channel, "' already exists in this vrImage object. \n Overwriting ...")
+  }
+  
+  if(inherits(value, "bitmap")){
+    object@image[[channel]] <- value
+  } else if(inherits(value, "magick-image")){
+    object@image[[channel]] <- magick::image_data(value)
+  } else if(inherits(value, "Image_Array")){
+    object@image[[channel]] <- value
+  } else {
+    stop("Please provide either a magick-image or bitmap class image object!")
+  }
+  
+  # return
+  object
+}
+
+#' @rdname vrImages
+#'
+#' @importFrom magick image_read
+#' @order 6
+#' @export
+setMethod("vrImages<-", "vrImage", vrImagesReplacevrImage)
+
+#' @rdname vrImages
+#'
+#' @importFrom magick image_read
+#' @order 6
+#' @export
+setMethod("vrImages<-", "vrSpatial", vrImagesReplacevrImage)
+
+vrMainImageVoltRon <- function(object, assay = NULL){
+  
+  # get assay names
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  # if assay = all, give a summary
+  if(!is.null(assay)){
+    if(assay == "all"){
+      spatial_names <- unlist(lapply(rownames(SampleMetadata(object)), function(x) paste(vrMainSpatial(object[[x]]), collapse = ",")))
+      spatial_names <- data.frame(Assay = assay_names, Spatial = spatial_names)
+      return(spatial_names)
+    }
+  }
+  
+  # get assay types
+  spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]])))
+  
+  # return data
+  spatial_data <- data.frame(Assay = assay_names, Spatial = spatial_names)
+  
+  # return
+  return(spatial_data)
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' If NULL, the default assay will be used, see \link{vrMainAssay}. If given as "all", then provides a summary of spatial systems across all assays.
+#'
+#' @rdname vrMainImage
+#' @order 2
+#' @export
+setMethod("vrMainImage", "VoltRon", vrMainImageVoltRon)
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#'
+#' @rdname vrMainSpatial
+#' @order 2
+#' @export
+setMethod("vrMainSpatial", "VoltRon", vrMainImageVoltRon)
+
+vrMainImageReplaceVoltRon <- function(object, assay = NULL, value){
+  
+  # get assay names
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  # get spatial metadata
+  sample.metadata <- SampleMetadata(object)
+  assayclass <- unique(sample.metadata[assay_names,"Assay"])
+  
+  # check for assay number
+  if(length(assayclass) == 1){
+    for(assy in assay_names)
+      vrMainSpatial(object[[assy]], ignore = TRUE) <- value
+  } else {
+    stop("You can only set the main spatial system of a single assay")
+  }
+  
+  return(object)
+}
+
+#' @param value the name of main image
+#'
+#' @rdname vrMainImage
+#' @order 4
+#' @export
+setMethod("vrMainImage<-", "VoltRon", vrMainImageReplaceVoltRon)
+
+#' @param value the name of main image
+#'
+#' @rdname vrMainSpatial
+#' @order 4
+#' @export
+setMethod("vrMainSpatial<-", "VoltRon", vrMainImageReplaceVoltRon)
+
+vrMainImagevrAssay <- function(object) return(object@main_image)
+
+#' @rdname vrMainImage
+#' @order 3
+#' @export
+setMethod("vrMainImage", "vrAssay", vrMainImagevrAssay)
+
+#' @rdname vrMainImage
+#' @order 3
+#' @export
+setMethod("vrMainImage", "vrAssayV2", vrMainImagevrAssay)
+
+#' @rdname vrMainSpatial
+#' @order 3
+#' @export
+setMethod("vrMainSpatial", "vrAssay", vrMainImagevrAssay)
+
+#' @rdname vrMainSpatial
+#' @order 3
+#' @export
+setMethod("vrMainSpatial", "vrAssayV2", vrMainImagevrAssay)
+
+#' @noRd
+.replaceMainSpatial <- function(object, ignore = FALSE, value){
+  
+  if(length(value) %in% c(1,2)){
+    
+    # get channel name if exists in the value
+    if(length(value) == 2){
+      channel <- value[2]
+      value <- value[1]
+    } else {
+      channel <- NULL
+    }
+    
+    # set main spatial/image
+    if(value %in% vrSpatialNames(object)){
+      object@main_image <- value
+      
+      # set channel
+      if(!is.null(channel))
+        vrMainChannel(object@image[[value]]) <- channel
+      
+    } else {
+      if(ignore){
+        warning("'",value,"' is not a spatial coordinate system in '", vrAssayNames(object),"'. Main system is still set to '", vrMainSpatial(object), "'")
+      } else {
+        stop("'",value,"' is not a spatial coordinate system in '", vrAssayNames(object),"'. Use ignore = TRUE for ignoring this message")
+      }
+    }
+    
+  } else {
+    stop("The Main image is set by either: \n    vrMainSpatial(object) <- c('<spatial name>', '<channel name>')\n or vrMainSpatial(object) <- '<spatial name>'")
+  }
+  
+  return(object)
+}
+
+#' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored.
+#' 
+#' @rdname vrMainImage
+#' @order 5
+#' @export
+setMethod("vrMainImage<-", "vrAssay", .replaceMainSpatial)
+
+#' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored.
+#' 
+#' @rdname vrMainImage
+#' @order 5
+#' @export
+setMethod("vrMainImage<-", "vrAssayV2", .replaceMainSpatial)
+
+#' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored.
+#' 
+#' @rdname vrMainSpatial
+#' @order 5
+#' @export
+setMethod("vrMainSpatial<-", "vrAssay", .replaceMainSpatial)
+
+#' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored.
+#'
+#' @rdname vrMainSpatial
+#' @order 5
+#' @export
+setMethod("vrMainSpatial<-", "vrAssayV2", .replaceMainSpatial)
+
+vrImageNamesVoltRon <- function(object, assay = NULL){
+  
+  # sample metadata
+  sample.metadata <- SampleMetadata(object)
+  
+  # get assay names
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  # if assay = all, give a summary
+  if(!is.null(assay)){
+    if(assay == "all"){
+      spatial_names <- unlist(lapply(assay_names, function(x) paste(vrSpatialNames(object[[x]]), collapse = ",")))
+      main_spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]])))
+      spatial_names <- data.frame(sample.metadata[assay_names,], Spatial = spatial_names, Main = main_spatial_names)
+      return(spatial_names)
+    }
+  }
+  
+  # unique names
+  spatial_names <- unique(unlist(lapply(assay_names, function(x) vrSpatialNames(object[[x]]))))
+  
+  return(spatial_names)
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' If NULL, the default assay will be used, see \link{vrMainAssay}. If equals to "all", then provides a summary of spatial systems across all assays
+#'
+#' @rdname vrImageNames
+#'
+#' @export
+setMethod("vrImageNames", "VoltRon", vrImageNamesVoltRon)
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}. If equals to "all", then provides a summary of spatial systems across all assays
+#'
+#' @rdname vrSpatialNames
+#'
+#' @export
+setMethod("vrSpatialNames", "VoltRon", vrImageNamesVoltRon)
+
+vrImageNamesvrAssay <- function(object) names(object@image)
+
+#' @rdname vrImageNames
+#'
+#' @export
+setMethod("vrImageNames", "vrAssay", vrImageNamesvrAssay)
+
+#' @rdname vrImageNames
+#'
+#' @export
+setMethod("vrImageNames", "vrAssayV2", vrImageNamesvrAssay)
+
+#' @rdname vrSpatialNames
+#'
+#' @export
+setMethod("vrSpatialNames", "vrAssay", vrImageNamesvrAssay)
+
+#' @rdname vrSpatialNames
+#'
+#' @export
+setMethod("vrSpatialNames", "vrAssayV2", vrImageNamesvrAssay)
+
+####
+## Channel Methods ####
+####
+
+vrMainChannelvrAssay <- function(object, name = NULL){
+  if(is.null(name)){
+    name <- vrMainSpatial(object)
+  }
+  return(vrMainChannel(object@image[[name]]))
+}
+
+#' @param name the name of the image
+#'
+#' @rdname vrMainChannel
+#' @order 2
+#' @export
+setMethod("vrMainChannel", "vrAssay", vrMainChannelvrAssay)
+
+#' @param name the name of the image
+#'
+#' @rdname vrMainChannel
+#' @order 2
+#' @export
+setMethod("vrMainChannel", "vrAssayV2", vrMainChannelvrAssay)
+
+vrMainChannelReplacevrAssay <- function(object, name = NULL, value){
+  if(is.null(name)){
+    name <- vrMainSpatial(object)
+  }
+  vrMainChannel(object@image[[name]]) <- value
+  return(object)
+}
+
+#' @param value the name of main channel
+#'
+#' @rdname vrMainChannel
+#' @order 4
+#' @export
+setMethod("vrMainChannel<-", "vrAssay", vrMainChannelReplacevrAssay)
+
+#' @param value the name of main channel
+#'
+#' @rdname vrMainChannel
+#' @order 4
+#' @export
+setMethod("vrMainChannel<-", "vrAssayV2", vrMainChannelReplacevrAssay)
+
+#' @rdname vrMainChannel
+#' @order 3
+#' @export
+setMethod("vrMainChannel", "vrImage", function(object){
+  return(object@main_channel)
+})
+
+#' @rdname vrMainChannel
+#' @order 3
+#' @export
+setMethod("vrMainChannel", "vrSpatial", function(object){
+  return(object@main_channel)
+})
+
+vrMainChannelReplacevrImage <- function(object, value){
+  
+  if(value %in% vrImageChannelNames(object)){
+    object@main_channel <- value
+  } else {
+    stop("'",value,"' is not a channel name")
+  }
+  return(object)
+}
+
+#' @param value the name of main channel
+#'
+#' @rdname vrMainChannel
+#' @method vrMainChannel<- vrImage
+#' @order 5
+#' @export
+setMethod("vrMainChannel<-", "vrImage", vrMainChannelReplacevrImage)
+
+#' @param value the name of main channel
+#'
+#' @rdname vrMainChannel
+#' @method vrMainChannel<- vrSpatial
+#' @order 5
+#' @export
+setMethod("vrMainChannel<-", "vrSpatial", vrMainChannelReplacevrImage)
+
+vrImageChannelNamesVoltRon <- function(object, assay = NULL){
+  
+  # get assay names
+  if(is.null(assay)){
+    assay_names <- vrAssayNames(object, assay = "all")
+  } else {
+    assay_names <- vrAssayNames(object, assay = assay)
+  }
+  
+  # sample metadata
+  sample.metadata <- SampleMetadata(object)
+  
+  # get image names
+  spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]])))
+  
+  # get channel names
+  image_channels <- unlist(lapply(assay_names, function(x) paste(vrImageChannelNames(object[[x]]), collapse = ",")))
+  
+  # return data
+  image_data <- data.frame(sample.metadata[assay_names,], Spatial = spatial_names, Channels = image_channels)
+  
+  # return
+  return(image_data)
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#'
+#' @rdname vrImageChannelNames
+#'
+#' @export
+setMethod("vrImageChannelNames", "VoltRon", vrImageChannelNamesVoltRon)
+
+vrImageChannelNamesvrAssay <- function(object, name = NULL){
+  
+  if(is.null(name)){
+    name <- vrMainSpatial(object)
+  } else {
+    if(!name %in% vrSpatialNames(object))
+      stop(name, " is not among any image in this vrAssay object")
+  }
+  
+  return(vrImageChannelNames(object@image[[name]]))
+}
+
+#' @param name the key of the image
+#'
+#' @rdname vrImageChannelNames
+#'
+#' @export
+setMethod("vrImageChannelNames", "vrAssay", vrImageChannelNamesvrAssay)
+
+#' @param name the key of the image
+#'
+#' @rdname vrImageChannelNames
+#'
+#' @export
+setMethod("vrImageChannelNames", "vrAssayV2", vrImageChannelNamesvrAssay)
+
+vrImageChannelNamesvrImage <- function(object){
+  if(is.null(names(object@image))){
+    return("No Channels or Images are found!")
+  } else{
+    return(names(object@image))
+  }
+}
+
+#' @rdname vrImageChannelNames
+#'
+#' @export
+setMethod("vrImageChannelNames", "vrImage", vrImageChannelNamesvrImage)
+
+#' @rdname vrImageChannelNames
+#'
+#' @export
+setMethod("vrImageChannelNames", "vrSpatial", vrImageChannelNamesvrImage)
+
+####
+## Managing Images ####
+####
+
+resizeImageVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, size = NULL){
+  
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  for(assy in assay_names){
+    object[[assy]] <- resizeImage(object[[assy]], name = name, reg = reg, size = size)
+  }
+  return(object)
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#' @param name the name of the image
+#' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested
+#' @param size the width of the resized image
+#'
+#' @rdname resizeImage
+#'
+#' @export
+setMethod("resizeImage", "VoltRon", resizeImageVoltRon)
+
+resizeImagevrAssay <- function(object, name = NULL, reg = FALSE, size = NULL){
+  
+  # get main image is main_image is null
+  if(is.null(name)) {
+    name <- object@main_image
+  }
+  
+  # check registered image
+  if(reg){
+    if(!paste0(name, "_reg") %in% vrSpatialNames(object)){
+      warning("There are no registered images with name ", name, "!")
+    } else {
+      name <- paste0(name, "_reg")
+    }
+  }
+  
+  # check main image
+  if(!name %in% vrSpatialNames(object)){
+    stop(name, " is not among any image in this vrAssay object")
+  }
+  
+  object@image[[name]] <- resizeImage(object@image[[name]], size = size)
+  
+  # return
+  return(object)
+}
+
+#' @rdname resizeImage
+#'
+#' @export
+setMethod("resizeImage", "vrAssay", resizeImagevrAssay)
+
+#' @rdname resizeImage
+#'
+#' @export
+setMethod("resizeImage", "vrAssayV2", resizeImagevrAssay)
+
+resizeImagevrImage <- function(object, size = NULL){
+  
+  # sizefactor
+  sizefactor <- image_info(vrImages(object))$width
+  
+  # check size
+  if(is.null(size))
+    size = sizefactor
+  if(!is.numeric(size))
+    stop("width size should be numeric")
+  if(!all.equal(size, as.integer(size)) & size > 0)
+    stop("width size should be a positive integer")
+  if(size < 100)
+    stop("width size cannot be less than 100px")
+  
+  # resize coordinates
+  vrCoordinates(object) <- (vrCoordinates(object)*size)/sizefactor
+  
+  # resize segments
+  vrSegments(object) <- lapply(vrSegments(object), function(x) {
+    x[,c("x", "y")] <- x[,c("x", "y")]*size/sizefactor
+    if(any(colnames(x) %in% c("rx", "ry"))){
+      x[,c("rx", "ry")] <- x[,c("rx", "ry")]*size/sizefactor
+    }
+    return(x)
+  })
+  
+  # resize images
+  size <- paste0(size,"x")
+  image_names <- vrImageChannelNames(object)
+  for(img in image_names){
+    img_data <- object@image[[img]]
+    if(inherits(img_data, "Image_Array")){
+      stop("Currently modulateImage only works on in-memory images!")
+    } else {
+      img_data <- magick::image_read(img_data)
+      img_data <- magick::image_resize(img_data, geometry = size)
+      object@image[[img]] <- magick::image_data(img_data) 
+    }
+  }
+  
+  # return
+  return(object)
+}
+
+#' @rdname resizeImage
+#'
+#' @importFrom magick image_info image_resize image_read image_data
+#' @export
+setMethod("resizeImage", "vrImage", resizeImagevrImage)
+
+#' @rdname resizeImage
+#'
+#' @importFrom magick image_info image_resize image_read image_data
+#' @export
+setMethod("resizeImage", "vrSpatial", resizeImagevrImage)
+
+modulateImageVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, channel = NULL, 
+                                  brightness = 100, saturation = 100, hue = 100, force = FALSE){
+  
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  for(assy in assay_names){
+    object[[assy]] <- modulateImage(object[[assy]], name = name, reg = reg, channel = channel, brightness = brightness, 
+                                    saturation = saturation, hue = hue, force = force)
+  }
+  return(object)
+}
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#' @param name the name of the image
+#' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested
+#' @param channel the name of the channel associated with the image
+#' @param brightness modulation of brightness as percentage of the current value (100 for no change)
+#' @param saturation modulation of saturation as percentage of the current value (100 for no change)
+#' @param hue modulation of hue is an absolute rotation of -180 degrees to +180 degrees from the current position corresponding to an argument range of 0 to 200 (100 for no change)
+#' @param force if TRUE, all channels will be modulated given no specific channel name
+#'
+#' @rdname modulateImage
+#'
+#' @export
+setMethod("modulateImage", "VoltRon", modulateImageVoltRon)
+
+modulateImagevrAssay <- function(object,  name = NULL, reg = FALSE, channel = NULL, 
+                                  brightness = 100, saturation = 100, hue = 100, force = FALSE){
+  
+  # check name
+  if(is.null(name)) {
+    name <- object@main_image
+  }
+  
+  # get registered image
+  if(reg){
+    if(!paste0(name, "_reg") %in% vrSpatialNames(object)){
+      warning("There are no registered images with name ", name, "!")
+    } else {
+      name <- paste0(name, "_reg")
+    }
+  }
+  
+  # check main image
+  if(!name %in% vrSpatialNames(object)){
+    stop(name, " is not among any image in this vrAssay object")
+  }
+  
+  object@image[[name]] <- modulateImage(object@image[[name]], channel = channel, brightness = brightness, 
+                                        saturation = saturation, hue = hue, force = force)
+  
+  # return
+  return(object)
+}
+
+#' @rdname modulateImage
+#'
+#' @export
+setMethod("modulateImage", "vrAssay", modulateImagevrAssay)
+
+#' @rdname modulateImage
+#'
+#' @export
+setMethod("modulateImage", "vrAssayV2", modulateImagevrAssay)
+
+modulateImagevrImage <- function(object, channel = NULL, brightness = 100, saturation = 100, hue = 100, force = FALSE){
+  
+  # check main_channels
+  if(is.null(channel) && (length(vrImageChannelNames(object)) > 1 && !force)){
+    stop("No channel name was specified. \n It is not advised to modulate multiple channels in the same time. \n Please type force = TRUE to allow this behaviour!")
+  }
+  
+  # get channel names
+  if(is.null(channel)){
+    channel <- vrImageChannelNames(object)
+  }
+  
+  # modulate image
+  for(img in channel){
+    img_data <- object@image[[img]]
+    if(inherits(img_data, "Image_Array")){
+      stop("Currently modulateImage only works on in-memory images!")
+    } else {
+      img_data <- magick::image_read(img_data)
+      # img_data <- getImage(object, name = img)
+      img_data <- magick::image_modulate(img_data, brightness = brightness, saturation = saturation, hue = hue)
+      object@image[[img]] <- magick::image_data(img_data) 
+    }
+  }
+  
+  # return
+  return(object)
+}
+
+#' @rdname modulateImage
+#'
+#' @importFrom magick image_info image_modulate
+#' @export
+setMethod("modulateImage", "vrImage", modulateImagevrImage)
+
+#' @rdname modulateImage
+#'
+#' @importFrom magick image_info image_modulate
+#' @export
+setMethod("modulateImage", "vrSpatial", modulateImagevrImage)
+
+combineChannelsVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, 
+                                    channels = NULL, colors = NULL, channel_key = "combined"){
+  
+  assay_names <- vrAssayNames(object, assay = assay)
+  
+  for(assy in assay_names){
+    object[[assy]] <- combineChannels(object[[assy]], name = name, reg = reg, 
+                                      channels = channels, colors = colors, channel_key = channel_key)
+  }
+  return(object)
+}
+
+
+#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
+#' if NULL, the default assay will be used, see \link{vrMainAssay}.
+#' @param name the name of the image
+#' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested
+#' @param channels the name of the channel associated with the image
+#' @param colors the colors associated with each channel
+#' @param channel_key the name of the new channel name
+#'
+#' @rdname combineChannels
+#'
+#' @export
+setMethod("combineChannels", "VoltRon", combineChannelsVoltRon)
+
+combineChannelsvrAssay <- function(object,  name = NULL, reg = FALSE, channels = NULL, colors = NULL, channel_key = "combined"){
+  
+  # check name
+  if(is.null(name)) {
+    name <- object@main_image
+  }
+  
+  # get registered image
+  if(reg){
+    if(!paste0(name, "_reg") %in% vrSpatialNames(object)){
+      warning("There are no registered images with name ", name, "!")
+    } else {
+      name <- paste0(name, "_reg")
+    }
+  }
+  
+  # check main image
+  if(!name %in% vrSpatialNames(object)){
+    stop(name, " is not among any image in this vrAssay object")
+  }
+  
+  object@image[[name]] <- combineChannels(object@image[[name]], channels = channels, colors = colors, channel_key = channel_key)
+  
+  # return
+  return(object)
+}
+
+#' @rdname combineChannels
+#'
+#' @export
+setMethod("combineChannels", "vrAssay", combineChannelsvrAssay)
+
+#' @rdname combineChannels
+#'
+#' @export
+setMethod("combineChannels", "vrAssayV2", combineChannelsvrAssay)
+
+combineChannelsvrImage <- function(object, channels = NULL, colors = NULL, channel_key = "combined"){
+  
+  # check channel names
+  if(is.null(channels)){
+    stop("No channel names were given")
+  } else {
+    if(any(!channels %in% vrImageChannelNames(object))){
+      warning("Some channel names do not match with the existing channels.")
+    }
+  }
+  
+  # check colors
+  if(is.null(colors)){
+    stop("No colors were given")
+  }
+  if(length(colors) != length(channels)){
+    stop("The length of colors do not match with the length of channels.")
+  }
+  
+  # configure channel and color names
+  colors <- colors[channels %in% vrImageChannelNames(object)]
+  channels <- channels[channels %in% vrImageChannelNames(object)]
+  names(colors) <- channels
+  
+  # get images and colorize
+  channel_list <- list()
+  composite_image <- NULL
+  for(img in channels){
+    channel_img <- vrImages(object, channel = img)
+    color_rgb <-  grDevices::col2rgb(colors[img])[,1]
+    imagedata <- as.numeric(magick::image_data(channel_img, channels = "rgb"))
+    imagedata[,,1] <- imagedata[,,1] * (color_rgb[1]/255)
+    imagedata[,,2] <- imagedata[,,2] * (color_rgb[2]/255)
+    imagedata[,,3] <- imagedata[,,3] * (color_rgb[3]/255)
+    channel_img <- magick::image_read(imagedata)
+    if(is.null(composite_image)){
+      composite_image <- channel_img
+    } else{
+      composite_image <- magick::image_composite(channel_img, composite_image, operator = "Plus")
+    }
+  }
+  
+  # combine channels
+  vrImages(object, channel = channel_key) <- composite_image
+  
+  # return
+  return(object)
+}
+
+#' @rdname combineChannels
+#'
+#' @importFrom magick image_read image_data image_composite
+#' @importFrom grDevices col2rgb
+#'
+#' @export
+setMethod("combineChannels", "vrImage", combineChannelsvrImage)
+
+#' @rdname combineChannels
+#'
+#' @export
+setMethod("combineChannels", "vrSpatial", combineChannelsvrImage)
+
+####
+# Other Methods ####
+####
+
+#' @rdname vrSpatialPoints
+#' @order 4
+#'
+#' @export
+setMethod("vrSpatialPoints", "vrImage", function(object) {
+  return(rownames(vrCoordinates(object)))
+})
+
+#' @rdname vrSpatialPoints
+#' @order 4
+#'
+#' @export
+setMethod("vrSpatialPoints", "vrSpatial", function(object) {
+  return(rownames(vrCoordinates(object)))
+})
+
+vrSpatialPointsReplacevrImage <- function(object, value) {
+  
+  # coordinates
+  if(length(rownames(object@coords)) != length(value)){
+    stop("The number of spatial points is not matching with the input")
+  } else {
+    rownames(object@coords)  <- value
+  }
+  
+  # segments
+  if(length(object@segments) > 0){
+    if(length(names(object@segments)) != length(value)){
+      stop("The number of spatial points is not matching with the input")
+    } else {
+      names(object@segments) <- value
+    }
+  }
+  
+  # return
+  return(object)
+}
+
+#' @param value new spatial points
+#'
+#' @rdname vrSpatialPoints
+#' @order 9
+#' @export
+setMethod("vrSpatialPoints<-", "vrImage", vrSpatialPointsReplacevrImage)
+
+#' @param value new spatial points
+#'
+#' @rdname vrSpatialPoints
+#' @order 9
+#' @export
+setMethod("vrSpatialPoints<-", "vrSpatial", vrSpatialPointsReplacevrImage)
+
+#' @rdname vrCoordinates
+#' @order 3
+#' @export
+setMethod("vrCoordinates", "vrImage", function(object) {
+    return(object@coords)
+})
+
+#' @rdname vrCoordinates
+#' @order 3
+#' @export
+setMethod("vrCoordinates", "vrSpatial", function(object) {
+  return(object@coords)
+})
+
+vrCoordinatesRepkacevrImage <- function(object, value) {
+  
+  # get coordinates
+  coords <- vrCoordinates(object)
+  
+  # stop if the rownames are not matching
+  if(any(vapply(rownames(value),is.null, logical(1))))
+    stop("Provided coordinates data does not have cell/spot/ROI names")
+  
+  if(!all(rownames(value) %in% rownames(coords)))
+    stop("Cant overwrite coordinates, non-existing cells/spots/ROIs!")
+  
+  # stop if the colnames there are more than two columns
+  if(ncol(value) == 2){
+    value <- cbind(value, 0)
+    colnames(value) <- c("x", "y", "z")
+  } else if(ncol(value) == 3){
+    colnames(value) <- c("x", "y", "z")
+  } else {
+    stop("Please make sure that the coordinates matrix have only two or three columns: for x and y coordinates")
+  }
+  
+  methods::slot(object = object, name = 'coords') <- value
+  return(object)
+}
+    
+#' @rdname vrCoordinates
+#' @order 6
+#' @importFrom methods slot
+#'
+#' @export
+setMethod("vrCoordinates<-", "vrImage", vrCoordinatesRepkacevrImage)
+
+#' @rdname vrCoordinates
+#' @order 6
+#' @importFrom methods slot
+#'
+#' @export
+setMethod("vrCoordinates<-", "vrSpatial", vrCoordinatesRepkacevrImage)
+
+#' @rdname vrSegments
+#' @order 4
+#' @export
+setMethod("vrSegments", "vrImage", function(object) {
+  return(object@segments)
+})
+
+#' @rdname vrSegments
+#' @order 4
+#' @export
+setMethod("vrSegments", "vrSpatial", function(object) {
+  return(object@segments)
+})
+
+vrSegmentsReplacevrImage <- function(object, value) {
+  
+  # get coordinates
+  segts <- vrSegments(object)
+  
+  # stop if the names are not matching
+  if(any(vapply(names(value),is.null, logical(1))))
+    stop("Provided coordinates data does not have cell/spot/ROI names")
+  
+  if(!all(names(value) %in% names(segts)))
+    stop("Cant overwrite coordinates, non-existing cells/spots/ROIs!")
+  
+  methods::slot(object = object, name = 'segments') <- value
+  return(object)
+}
+
+#' @rdname vrSegments
+#' @order 7
+#' @importFrom methods slot
+#' @export
+setMethod("vrSegments<-", "vrImage", vrSegmentsReplacevrImage)
+
+#' @rdname vrSegments
+#' @order 7
+#' @importFrom methods slot
+#' @export
+setMethod("vrSegments<-", "vrSpatial", vrSegmentsReplacevrImage)
+
+####
+# Demultiplex Images ####
+####
+
+#' demuxVoltRon
+#'
+#' Subsetting/demultiplexing of the VoltRon Object using interactive shiny app
+#'
+#' @param object a VoltRon object
+#' @param max.pixel.size the initial width of the object image
+#' @param use.points.only use spatial points instead of the reference image
+#' @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
+#' @importFrom magick image_scale image_info image_ggplot
+#' @importFrom ggplot2 geom_rect
+#' @importFrom dplyr filter add_row tibble
+#' @importFrom ggrepel geom_label_repel
+#'
+demuxVoltRon <- function(object, max.pixel.size = 1200, use.points.only = FALSE, shiny.options = list(launch.browser = getOption("shiny.launch.browser", interactive())))
+{
+  # check if there are only one assay in the object
+  sample.metadata <- SampleMetadata(object)
+  
+  if(length(unique(sample.metadata$Layer)) > 1)
+    stop("You can only subset a single VoltRon layer at a time")
+  
+  # get image
+  images <- vrImages(object[[vrAssayNames(object)]], as.raster = TRUE)
+  if(!inherits(images, "Image_Array")){
+    images <- magick::image_read(images)
+  }
+  
+  # scale 
+  imageinfo <- getImageInfo(images)
+  scale_factor <- 1
+  if(imageinfo$width > max.pixel.size){
+    scale_factor <- imageinfo$width/max.pixel.size
+  }
+  if(use.points.only){
+    object_small <- resizeImage(object, size = max.pixel.size)
+    image_info_small <- magick::image_info(vrImages(object_small))
+    coords <- as.data.frame(vrCoordinates(object_small, reg = FALSE))
+    pl <- ggplot() + geom_point(aes_string(x = "x", y = "y"), coords, size = 1.5, color = "black") +
+      theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank(),
+            axis.line=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(),
+            legend.margin = margin(0,0,0,0), plot.margin = unit( c(0,0,0,0),"in")) +
+      coord_fixed()
+  } else {
+    pl <- plotImage(images, max.pixel.size = max.pixel.size)
+  }
+
+  # get the ui and server
+  
+  # UI ####
+  ui <- fluidPage(
+    
+    # use javascript extensions for Shiny
+    shinyjs::useShinyjs(),
+    
+    # sidebar
+    sidebarLayout(position = "left",
+                  
+                  # Side bar
+                  sidebarPanel(
+                    tags$style(make_css(list('.well', 'margin', '7%'))),
+                    
+                    # Interface
+                    fluidRow(
+                      column(12,h4("Interactive Subsetting"))
+                    ),
+                    
+                    # Buttons
+                    fluidRow(
+                      column(12,shiny::actionButton("resetpoints", "Remove Box")),
+                      br(),
+                      column(12,shiny::actionButton("addbox", "Add Box")),
+                      br()
+                    ),
+                    
+                    # instructions
+                    h4("How to use"),
+                    p(style="font-size: 12px;", strong("Single-L-hold-drag:"), "Select area"),
+                    p(style="font-size: 12px;", strong("Add Box"), " to set a new subset"),
+                    p(style="font-size: 12px;", strong("Remove Box"), " to reset the box"),
+                    br(),
+                    
+                    # Subsets
+                    fluidRow(
+                      column(12,h4("Selected Subsets")),
+                      uiOutput("textbox_ui"),
+                      br()
+                    ),
+                    
+                    # Subsets
+                    fluidRow(
+                      column(12,shiny::actionButton("done", "Done"))
+                    ),
+                    br(),
+                    
+                    # panel options
+                    width = 3,
+                  ),
+                  
+                  mainPanel(
+                    
+                    # main image
+                    br(),
+                    br(),
+                    fluidRow(
+                      plotOutput("cropped_image",
+                                 height = "1000px",
+                                 brush = brushOpts(
+                                   id = "plot_brush", fill = "green",
+                                   resetOnNew = TRUE
+                                 )),
+                    ),
+                    
+                    # panel options
+                    width = 9
+                  )
+    )
+  )
+  
+  # Server ####
+  server <- function(input, output, session) {
+    
+    ## Importing images and variables ####
+    
+    # selected corner list
+    selected_corners_list_image <- reactiveVal(dplyr::tibble(box = character()))
+    selected_corners_list <- reactiveVal(list())
+    
+    ## Region Annotators ####
+    
+    ### Text Box Management ####
+    
+    # Reactive value to store the number of textboxes
+    textboxes <- reactiveVal(numeric(0))
+    
+    # Initialize textbox values if n > 0, get already existing segments
+    textbox_values <- reactiveValues()
+    
+    # Dynamically generate UI for textboxes and remove buttons
+    output$textbox_ui <- renderUI({
+      lapply(textboxes(), function(i) {
+        column(12,
+               textInputwithButton(textinputId = paste0("sample", i), label = paste0("Subset ", i),
+                                   buttoninputId = paste0("remove", i), value = isolate(textbox_values[[paste0("sample", i)]]), 
+                                   onclick = sprintf('Shiny.setInputValue("remove", %d)', i))
+        )
+      })
+    })
+    
+    # Observe changes in each textbox to update their values
+    observe({
+      lapply(textboxes(), function(i) {
+        observeEvent(input[[paste0("sample", i)]], {
+          textbox_values[[paste0("sample", i)]] <- isolate(input[[paste0("sample", i)]])
+        }, ignoreNULL = FALSE)
+      })
+    })
+    
+    ### Reset box ####
+    observeEvent(input$resetpoints, {
+      session$resetBrush("plot_brush")
+    })
+    
+    ### Remove box ####
+    
+    # Observe event to remove textbox when the button is clicked
+    observeEvent(input$remove, {
+      
+      # remove one point
+      selected_corners_list(selected_corners_list()[!(textboxes() == as.numeric(isolate(input$remove)))])
+      
+      # Update the reactive value to remove the textbox
+      textboxes(setdiff(textboxes(), as.numeric(isolate(input$remove))))
+      
+      # Remove the value from textbox_values
+      textbox_values[[paste0("sample", as.numeric(input$remove))]] <- NULL
+      
+    }, ignoreInit = TRUE)
+    
+    ### Add box ####
+    observeEvent(input$addbox, {
+      
+      # get corners
+      brush <- input$plot_brush
+      
+      # add a box if brush is active
+      if(!is.null(brush)){
+        
+        # corners 
+        corners <- data.frame(x = c(brush$xmin, brush$xmax), 
+                              y = c(brush$ymax, brush$ymin))
+        
+        # record corners
+        selected_corners_list(c(selected_corners_list(), list(corners)))
+        
+        # adjust corners
+        corners <- corners*scale_factor
+        corners <- FromBoxToCrop(corners, imageinfo)
+
+        # add to box list
+        selected_corners_list_image() %>%
+          dplyr::add_row(box = corners) %>%
+          selected_corners_list_image()
+        
+        # reset box
+        session$resetBrush("plot_brush")
+        
+        # add buttons
+        new_id <- if (length(textboxes()) == 0) 1 else max(textboxes()) + 1
+        textboxes(c(textboxes(), new_id))
+        textbox_values[[paste0("sample", new_id)]] <- ""
+      }
+    })
+    
+    ## Main observable ####
+    observe({
+      
+      # output image
+      output[["cropped_image"]] <- renderPlot({
+        
+        # visualize already selected boxes
+        if(length(selected_corners_list()) > 0){
+          for (i in seq_len(length(selected_corners_list()))){
+            corners <- apply(as.matrix(selected_corners_list()[[i]]),2,as.numeric)
+            if(nrow(corners) > 1){
+              corners <- as.data.frame(rbind(cbind(corners[1,1], corners[seq_len(2),2]), cbind(corners[2,1], corners[rev(seq_len(2)),2])))
+              colnames(corners) <- c("x", "y")
+              pl <- pl + ggplot2::geom_polygon(aes(x = x, y = y), data = corners, alpha = 0.3, fill = "green", color = "black")
+              
+            }
+          }
+        }
+        
+        # put labels of the already selected polygons
+        if(length(selected_corners_list()) > 0){
+          for (i in seq_len(length(selected_corners_list()))){
+            corners <- selected_corners_list()[[i]]
+            corners <- as.data.frame(rbind(cbind(corners[1,1], corners[seq_len(2),2]), cbind(corners[2,1], corners[rev(seq_len(2)),2])))
+            corners <- data.frame(x = mean(corners[,1]), y = max(corners[,2]), sample = paste("Subset ", isolate(textboxes()[i])))
+            pl <- pl +
+              ggrepel::geom_label_repel(mapping = aes(x = x, y = y, label = sample), data = corners,
+                                        size = 5, direction = "y", nudge_y = 6, box.padding = 0, label.padding = 1, seed = 1, color = "red")
+          }
+        }
+        
+        # return graph
+        pl
+      })
+    })
+    
+    ## Done ####
+    
+    # show "Done" if a region is selected already
+    observe({
+      if(nrow(selected_corners_list_image()) > 0){
+        shinyjs::show(id = "done")
+      } else {
+        shinyjs::hide(id = "done")
+      }
+    })
+    
+    # observe for done and return the list of objects
+    observeEvent(input$done, {
+      if(nrow(selected_corners_list_image()) > 0){
+        subsets <- list()
+        box_list <- selected_corners_list_image()
+        
+        # collect labels
+        sample_names <- vapply(seq_len(length(box_list$box)), function(i) input[[paste0("sample",i)]], character(1))
+
+        # check if sample names are present
+        if(any(sample_names == "")) {
+          showNotification("Some subsets have blank (empty!) sample names.")
+        } else{
+          for(i in seq_len(length(box_list$box))){
+            temp <- subsetVoltRon(object, image = box_list$box[i])
+            temp$Sample <- sample_names[i]
+            subsets[[sample_names[i]]] <- temp
+          }
+          stopApp(list(subsets = subsets, subset_info_list = box_list))
+        }
+        
+      } else {
+        showNotification("You have not selected a subset yet!")
+      }
+    })
+  }
+  
+  # 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() {
+                      })
+                    })
+  )
+}
+
+
+#' FromBoxToCrop
+#'
+#' get magick crop information from a dataframe of box corners
+#'
+#' @param corners topleft and bottomright coordinates of bounding box
+#' @param imageinfo info of the image
+#' 
+#' @noRd
+FromBoxToCrop <- function(corners, imageinfo){
+  
+  corners <- apply(corners,2,ceiling)
+  
+  # fix for limits
+  corners[1,1] <- ifelse(corners[1,1] < 0, 0, corners[1,1])
+  corners[1,1] <- ifelse(corners[1,1] > imageinfo$width, imageinfo$width, corners[1,1])
+  corners[2,1] <- ifelse(corners[2,1] < 0, 0, corners[2,1])
+  corners[2,1] <- ifelse(corners[2,1] > imageinfo$width, imageinfo$width, corners[2,1])
+  corners[1,2] <- ifelse(corners[1,2] < 0, 0, corners[1,2])
+  corners[1,2] <- ifelse(corners[1,2] > imageinfo$height, imageinfo$height, corners[1,2])
+  corners[2,2] <- ifelse(corners[2,2] < 0, 0, corners[2,2])
+  corners[2,2] <- ifelse(corners[2,2] > imageinfo$height, imageinfo$height, corners[2,2])
+
+  # get crop info
+  corners <- paste0(abs(corners[2,1]-corners[1,1]), "x",
+                    abs(corners[2,2]-corners[1,2]), "+",
+                    min(corners[,1]), "+", imageinfo$height - max(corners[,2]))
+
+  # corners 
+  return(corners)
+}
+
+#' FromSegmentToCrop
+#'
+#' get magick crop information from coordinates of a segment
+#'
+#' @param segment coordinates of a segment
+#' @param imageinfo info of the image
+#' 
+#' @export
+FromSegmentToCrop <- function(segment, imageinfo){
+  
+  # make box from segment coordinates
+  corners <- matrix(c(0,0,0,0), nrow = 2, ncol = 2)
+  corners[1,1] <- min(segment[,1])
+  corners[2,1] <- max(segment[,1])
+  corners[1,2] <- max(segment[,2])
+  corners[2,2] <- min(segment[,2])
+
+  # get crop from box
+  corners <- FromBoxToCrop(corners, imageinfo)
+
+  # corners 
+  return(corners)
+}
+