Datasets
Models
Diff of
/R/image.R
[000000]
..
[413088]
Switch to unified view
| a | b/R/image.R | ||
|---|---|---|---|
| 1 | #### |
||
| 2 | # Create vrImage Object #### |
||
| 3 | #### |
||
| 4 | |||
| 5 | #' formImage |
||
| 6 | #' |
||
| 7 | #' Create a vrImage (VoltRon image) object |
||
| 8 | #' |
||
| 9 | #' @param coords the coordinates of the spatial points |
||
| 10 | #' @param segments the list of segments each associated with a spatial point |
||
| 11 | #' @param image a singelton or list of images as magick-image objects |
||
| 12 | #' @param main_channel the key of the main channel of vrImage object |
||
| 13 | #' |
||
| 14 | #' @importFrom magick image_data image_read image_info |
||
| 15 | #' @importFrom methods new |
||
| 16 | #' |
||
| 17 | #' @export |
||
| 18 | #' |
||
| 19 | formImage <- function(coords, segments = list(), image = NULL, main_channel = NULL){ |
||
| 20 | |||
| 21 | # get coordinates |
||
| 22 | if(inherits(coords, "data.frame")){ |
||
| 23 | coords <- as.matrix(coords) |
||
| 24 | } |
||
| 25 | if(!inherits(coords, c("matrix", "dgCMatrix", "Matrix", "IterableMatrix"))){ |
||
| 26 | stop("Coordinates table should either of a matrix or data.frame class!") |
||
| 27 | } |
||
| 28 | if(ncol(coords) == 2){ |
||
| 29 | coords <- cbind(coords,0) |
||
| 30 | colnames(coords) <- c("x", "y", "z") |
||
| 31 | } |
||
| 32 | if(!ncol(coords) %in% c(2,3)){ |
||
| 33 | stop("The length of colnames of the coordinates matrix should be either two or three!") |
||
| 34 | } |
||
| 35 | |||
| 36 | # get segments |
||
| 37 | if(length(segments) > 0){ |
||
| 38 | if(length(segments) == length(rownames(coords))){ |
||
| 39 | names(segments) <- rownames(coords) |
||
| 40 | } else { |
||
| 41 | stop("Number of segments doesnt match the number of points!") |
||
| 42 | } |
||
| 43 | } |
||
| 44 | |||
| 45 | # check if the image input is a list |
||
| 46 | if(!is.null(image)){ |
||
| 47 | if(is.list(image)){ |
||
| 48 | |||
| 49 | # enter names if there are no names |
||
| 50 | if(is.null(names(image))) |
||
| 51 | names(image) <- paste("channel_", seq_len(length(image)), sep = "") |
||
| 52 | |||
| 53 | # get image information |
||
| 54 | imageinfo <- vapply(image, function(x) as.matrix(magick::image_info(x)[,c("width", "height")])[1,], |
||
| 55 | numeric(2), USE.NAMES = TRUE) |
||
| 56 | flag <- all(apply(imageinfo, 1, function(x) length(unique(x)) == 1)) |
||
| 57 | |||
| 58 | # |
||
| 59 | if(!flag){ |
||
| 60 | stop("When providing multiple images as channels, make sure that all images have the same dimensionality!") |
||
| 61 | } else { |
||
| 62 | image <- lapply(image, magick::image_data) |
||
| 63 | names(image) <- colnames(imageinfo) |
||
| 64 | if(is.null(main_channel)) |
||
| 65 | main_channel <- names(image)[1] |
||
| 66 | } |
||
| 67 | } else { |
||
| 68 | image <- list(magick::image_data(image)) |
||
| 69 | if(is.null(main_channel)) |
||
| 70 | main_channel <- "channel_1" |
||
| 71 | names(image) <- main_channel |
||
| 72 | } |
||
| 73 | } else { |
||
| 74 | image <- list() |
||
| 75 | main_channel <- "" |
||
| 76 | } |
||
| 77 | |||
| 78 | # make vrimage object |
||
| 79 | methods::new("vrSpatial", coords = coords, segments = segments, image = image, main_channel = main_channel) |
||
| 80 | } |
||
| 81 | |||
| 82 | ### Subset vrImage objects #### |
||
| 83 | |||
| 84 | subsetvrImage <- function(x, subset, spatialpoints = NULL, image = NULL) { |
||
| 85 | |||
| 86 | # start |
||
| 87 | object <- x |
||
| 88 | |||
| 89 | if (!missing(x = subset)) { |
||
| 90 | subset <- rlang::enquo(arg = subset) |
||
| 91 | } |
||
| 92 | |||
| 93 | # coords and segments |
||
| 94 | coords <- vrCoordinates(object) |
||
| 95 | segments <- vrSegments(object) |
||
| 96 | |||
| 97 | if(!is.null(spatialpoints)){ |
||
| 98 | |||
| 99 | # check if spatial points are here |
||
| 100 | spatialpoints <- intersect(spatialpoints, rownames(coords)) |
||
| 101 | if(length(spatialpoints) == 0){ |
||
| 102 | return(NULL) |
||
| 103 | } |
||
| 104 | |||
| 105 | # coordinates |
||
| 106 | vrCoordinates(object) <- coords[spatialpoints,, drop = FALSE] |
||
| 107 | |||
| 108 | # segments |
||
| 109 | if(length(segments) > 0) |
||
| 110 | vrSegments(object) <- segments[spatialpoints] |
||
| 111 | |||
| 112 | } else if(!is.null(image)) { |
||
| 113 | |||
| 114 | # get one image |
||
| 115 | vrimage <- vrImages(object) |
||
| 116 | |||
| 117 | # coordinates |
||
| 118 | cropped_coords <- subsetCoordinates(coords, vrimage, image) |
||
| 119 | vrCoordinates(object) <- cropped_coords |
||
| 120 | |||
| 121 | # segments |
||
| 122 | cropped_segments <- segments[rownames(cropped_coords)] |
||
| 123 | if(length(segments) > 0){ |
||
| 124 | segments[rownames(cropped_coords)] <- subsetSegments(cropped_segments, vrimage, image) |
||
| 125 | vrSegments(object) <- segments |
||
| 126 | } |
||
| 127 | |||
| 128 | # spatial points |
||
| 129 | # object <- subset.vrImage(object, spatialpoints = rownames(cropped_coords)) |
||
| 130 | object <- subsetvrImage(object, spatialpoints = rownames(cropped_coords)) |
||
| 131 | |||
| 132 | # image |
||
| 133 | for(img in vrImageChannelNames(object)){ |
||
| 134 | |||
| 135 | # check if the image is either ondisk or inmemory |
||
| 136 | img_data <- object@image[[img]] |
||
| 137 | if(inherits(img_data, "Image_Array")){ |
||
| 138 | crop_info_int <- as.integer(strsplit(image, split = "[x|+]")[[1]]) |
||
| 139 | 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]))) |
||
| 140 | object@image[[img]] <- img_data |
||
| 141 | } else { |
||
| 142 | img_data <- magick::image_read(img_data) |
||
| 143 | img_data <- magick::image_crop(img_data, image) |
||
| 144 | object@image[[img]] <- magick::image_data(img_data) |
||
| 145 | } |
||
| 146 | } |
||
| 147 | } |
||
| 148 | |||
| 149 | # set VoltRon class |
||
| 150 | return(object) |
||
| 151 | } |
||
| 152 | |||
| 153 | #' Subsetting vrImage objects |
||
| 154 | #' |
||
| 155 | #' Given a vrImage object, subset the object given one of the attributes. |
||
| 156 | #' |
||
| 157 | #' @param x A vrImage object |
||
| 158 | #' @param subset Logical statement for subsetting |
||
| 159 | #' @param spatialpoints the set of spatial points to subset the object |
||
| 160 | #' @param image the subseting string passed to \link{image_crop} |
||
| 161 | #' |
||
| 162 | #' @method subset vrImage |
||
| 163 | #' @order 5 |
||
| 164 | #' |
||
| 165 | #' @importFrom rlang enquo |
||
| 166 | #' @importFrom magick image_crop |
||
| 167 | #' |
||
| 168 | #' @export |
||
| 169 | setMethod("subset", "vrImage", subsetvrImage) |
||
| 170 | |||
| 171 | #' Subsetting vrSpatial objects |
||
| 172 | #' |
||
| 173 | #' Given a vrSpatial object, subset the object given one of the attributes. |
||
| 174 | #' |
||
| 175 | #' @param x A vrSpatial object |
||
| 176 | #' @param subset Logical statement for subsetting |
||
| 177 | #' @param spatialpoints the set of spatial points to subset the object |
||
| 178 | #' @param image the subseting string passed to \link{image_crop} |
||
| 179 | #' |
||
| 180 | #' @method subset vrSpatial |
||
| 181 | #' @order 5 |
||
| 182 | #' |
||
| 183 | #' @importFrom rlang enquo |
||
| 184 | #' @importFrom magick image_crop |
||
| 185 | #' |
||
| 186 | #' @export |
||
| 187 | #' |
||
| 188 | setMethod("subset", "vrSpatial", subsetvrImage) |
||
| 189 | |||
| 190 | #### |
||
| 191 | # Methods #### |
||
| 192 | #### |
||
| 193 | |||
| 194 | vrImagesVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, channel = NULL, as.raster = FALSE, scale.perc = 100){ |
||
| 195 | |||
| 196 | # get assay names |
||
| 197 | if(is.null(assay)){ |
||
| 198 | assay_names <- vrAssayNames(object, assay = "all") |
||
| 199 | } else { |
||
| 200 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 201 | } |
||
| 202 | |||
| 203 | # get images |
||
| 204 | images <- sapply(assay_names, function(assy) vrImages(object[[assy]], |
||
| 205 | name = name, |
||
| 206 | reg = reg, |
||
| 207 | channel = channel, |
||
| 208 | as.raster = as.raster, |
||
| 209 | scale.perc = scale.perc), USE.NAMES = TRUE) |
||
| 210 | if(length(images) == 1){ |
||
| 211 | return(images[[1]]) |
||
| 212 | } else { |
||
| 213 | return(images) |
||
| 214 | } |
||
| 215 | } |
||
| 216 | |||
| 217 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 218 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 219 | #' @param name the name of the main spatial system |
||
| 220 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested |
||
| 221 | #' @param channel the name of the channel associated with the image |
||
| 222 | #' @param as.raster return as raster |
||
| 223 | #' @param scale.perc scale percentage if lower resolution image needed |
||
| 224 | #' |
||
| 225 | #' @rdname vrImages |
||
| 226 | #' @order 2 |
||
| 227 | #' @export |
||
| 228 | setMethod("vrImages", "VoltRon", vrImagesVoltRon) |
||
| 229 | |||
| 230 | vrImagesvrAssay <- function(object, name = NULL, reg = FALSE, channel = NULL, as.raster = FALSE, scale.perc = 100){ |
||
| 231 | |||
| 232 | # check image name |
||
| 233 | if(is.null(name)) { |
||
| 234 | name <- object@main_image |
||
| 235 | } |
||
| 236 | |||
| 237 | # get registered image |
||
| 238 | if(reg){ |
||
| 239 | if(!paste0(name, "_reg") %in% vrSpatialNames(object)){ |
||
| 240 | warning("There are no registered images with name ", name, "!") |
||
| 241 | } else { |
||
| 242 | name <- paste0(name, "_reg") |
||
| 243 | } |
||
| 244 | } |
||
| 245 | |||
| 246 | # check main image |
||
| 247 | if(!name %in% vrSpatialNames(object)){ |
||
| 248 | stop(name, " is not among any image in this vrAssay object") |
||
| 249 | } |
||
| 250 | |||
| 251 | return(vrImages(object@image[[name]], channel = channel, as.raster = as.raster, scale.perc = scale.perc)) |
||
| 252 | } |
||
| 253 | |||
| 254 | #' @rdname vrImages |
||
| 255 | #' @order 3 |
||
| 256 | #' @export |
||
| 257 | setMethod("vrImages", "vrAssay", vrImagesvrAssay) |
||
| 258 | |||
| 259 | #' @rdname vrImages |
||
| 260 | #' @order 3 |
||
| 261 | #' @export |
||
| 262 | setMethod("vrImages", "vrAssayV2", vrImagesvrAssay) |
||
| 263 | |||
| 264 | vrImagesReplacevrAssay <- function(object, name = NULL, channel = NULL, reg = FALSE, value) { |
||
| 265 | if(is.null(name)) { |
||
| 266 | name <- object@main_image |
||
| 267 | } |
||
| 268 | |||
| 269 | if(reg){ |
||
| 270 | name <- paste0(name, "_reg") |
||
| 271 | } |
||
| 272 | |||
| 273 | if(inherits(value, "vrImage") | inherits(value, "vrSpatial")){ |
||
| 274 | object@image[[name]] <- value |
||
| 275 | } else { |
||
| 276 | if(!is.null(channel)){ |
||
| 277 | vrImages(object@image[[name]], channel = channel) <- value |
||
| 278 | } |
||
| 279 | } |
||
| 280 | return(object) |
||
| 281 | } |
||
| 282 | |||
| 283 | #' @param value new image |
||
| 284 | #' |
||
| 285 | #' @rdname vrImages |
||
| 286 | #' |
||
| 287 | #' @importFrom magick image_data |
||
| 288 | #' @order 5 |
||
| 289 | #' @export |
||
| 290 | setMethod("vrImages<-", "vrAssay", vrImagesReplacevrAssay) |
||
| 291 | |||
| 292 | #' @param value new image |
||
| 293 | #' |
||
| 294 | #' @rdname vrImages |
||
| 295 | #' |
||
| 296 | #' @importFrom magick image_data |
||
| 297 | #' @order 5 |
||
| 298 | #' @export |
||
| 299 | setMethod("vrImages<-", "vrAssayV2", vrImagesReplacevrAssay) |
||
| 300 | |||
| 301 | vrImagesvrImage <- function(object, channel = NULL, as.raster = FALSE, scale.perc = 100){ |
||
| 302 | |||
| 303 | # check channels |
||
| 304 | if(is.null(channel)){ |
||
| 305 | channel <- object@main_channel |
||
| 306 | } else { |
||
| 307 | if(!channel %in% vrImageChannelNames(object)){ |
||
| 308 | warning("'", channel, "' is not among any channel in this vrImage object!") |
||
| 309 | return(NULL) |
||
| 310 | } |
||
| 311 | } |
||
| 312 | |||
| 313 | # correct image scale |
||
| 314 | if(!is.numeric(scale.perc)){ |
||
| 315 | stop("scale.perc should be between 0 and 1") |
||
| 316 | } |
||
| 317 | if(scale.perc <= 0 || scale.perc > 100){ |
||
| 318 | stop("scale.perc should be between 0 and 100") |
||
| 319 | } |
||
| 320 | |||
| 321 | # return image |
||
| 322 | if(channel!=""){ |
||
| 323 | |||
| 324 | # get image |
||
| 325 | img <- object@image[[channel]] |
||
| 326 | if(as.raster){ |
||
| 327 | |||
| 328 | # return raster image format |
||
| 329 | return(img) |
||
| 330 | |||
| 331 | } else { |
||
| 332 | |||
| 333 | # get image as array if image is stored as a DelayedArray |
||
| 334 | if(inherits(img, "Image_Array")){ |
||
| 335 | # img <- as.array(img@seed) |
||
| 336 | img <- as.array(img) |
||
| 337 | img <- array(as.raw(img), dim = dim(img)) |
||
| 338 | } |
||
| 339 | |||
| 340 | # read image |
||
| 341 | img <- magick::image_read(img) |
||
| 342 | |||
| 343 | # scale image if needed |
||
| 344 | if(scale.perc < 100){ |
||
| 345 | img <- image_resize(img, geometry = magick::geometry_size_percent(scale.perc)) |
||
| 346 | } |
||
| 347 | |||
| 348 | # return regular image |
||
| 349 | return(img) |
||
| 350 | } |
||
| 351 | } else{ |
||
| 352 | warning("No image was found!") |
||
| 353 | return(NULL) |
||
| 354 | } |
||
| 355 | } |
||
| 356 | |||
| 357 | #' @rdname vrImages |
||
| 358 | #' @order 4 |
||
| 359 | #' @importFrom magick image_read geometry_size_percent |
||
| 360 | #' |
||
| 361 | #' @export |
||
| 362 | setMethod("vrImages", "vrImage", vrImagesvrImage) |
||
| 363 | |||
| 364 | #' @rdname vrImages |
||
| 365 | #' @order 4 |
||
| 366 | #' @importFrom magick image_read geometry_size_percent |
||
| 367 | #' |
||
| 368 | #' @export |
||
| 369 | setMethod("vrImages", "vrSpatial", vrImagesvrImage) |
||
| 370 | |||
| 371 | vrImagesReplacevrImage <- function(object, channel = NULL, value){ |
||
| 372 | |||
| 373 | if(channel %in% vrImageChannelNames(object)){ |
||
| 374 | warning("A channel with name '", channel, "' already exists in this vrImage object. \n Overwriting ...") |
||
| 375 | } |
||
| 376 | |||
| 377 | if(inherits(value, "bitmap")){ |
||
| 378 | object@image[[channel]] <- value |
||
| 379 | } else if(inherits(value, "magick-image")){ |
||
| 380 | object@image[[channel]] <- magick::image_data(value) |
||
| 381 | } else if(inherits(value, "Image_Array")){ |
||
| 382 | object@image[[channel]] <- value |
||
| 383 | } else { |
||
| 384 | stop("Please provide either a magick-image or bitmap class image object!") |
||
| 385 | } |
||
| 386 | |||
| 387 | # return |
||
| 388 | object |
||
| 389 | } |
||
| 390 | |||
| 391 | #' @rdname vrImages |
||
| 392 | #' |
||
| 393 | #' @importFrom magick image_read |
||
| 394 | #' @order 6 |
||
| 395 | #' @export |
||
| 396 | setMethod("vrImages<-", "vrImage", vrImagesReplacevrImage) |
||
| 397 | |||
| 398 | #' @rdname vrImages |
||
| 399 | #' |
||
| 400 | #' @importFrom magick image_read |
||
| 401 | #' @order 6 |
||
| 402 | #' @export |
||
| 403 | setMethod("vrImages<-", "vrSpatial", vrImagesReplacevrImage) |
||
| 404 | |||
| 405 | vrMainImageVoltRon <- function(object, assay = NULL){ |
||
| 406 | |||
| 407 | # get assay names |
||
| 408 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 409 | |||
| 410 | # if assay = all, give a summary |
||
| 411 | if(!is.null(assay)){ |
||
| 412 | if(assay == "all"){ |
||
| 413 | spatial_names <- unlist(lapply(rownames(SampleMetadata(object)), function(x) paste(vrMainSpatial(object[[x]]), collapse = ","))) |
||
| 414 | spatial_names <- data.frame(Assay = assay_names, Spatial = spatial_names) |
||
| 415 | return(spatial_names) |
||
| 416 | } |
||
| 417 | } |
||
| 418 | |||
| 419 | # get assay types |
||
| 420 | spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]]))) |
||
| 421 | |||
| 422 | # return data |
||
| 423 | spatial_data <- data.frame(Assay = assay_names, Spatial = spatial_names) |
||
| 424 | |||
| 425 | # return |
||
| 426 | return(spatial_data) |
||
| 427 | } |
||
| 428 | |||
| 429 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 430 | #' 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. |
||
| 431 | #' |
||
| 432 | #' @rdname vrMainImage |
||
| 433 | #' @order 2 |
||
| 434 | #' @export |
||
| 435 | setMethod("vrMainImage", "VoltRon", vrMainImageVoltRon) |
||
| 436 | |||
| 437 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 438 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 439 | #' |
||
| 440 | #' @rdname vrMainSpatial |
||
| 441 | #' @order 2 |
||
| 442 | #' @export |
||
| 443 | setMethod("vrMainSpatial", "VoltRon", vrMainImageVoltRon) |
||
| 444 | |||
| 445 | vrMainImageReplaceVoltRon <- function(object, assay = NULL, value){ |
||
| 446 | |||
| 447 | # get assay names |
||
| 448 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 449 | |||
| 450 | # get spatial metadata |
||
| 451 | sample.metadata <- SampleMetadata(object) |
||
| 452 | assayclass <- unique(sample.metadata[assay_names,"Assay"]) |
||
| 453 | |||
| 454 | # check for assay number |
||
| 455 | if(length(assayclass) == 1){ |
||
| 456 | for(assy in assay_names) |
||
| 457 | vrMainSpatial(object[[assy]], ignore = TRUE) <- value |
||
| 458 | } else { |
||
| 459 | stop("You can only set the main spatial system of a single assay") |
||
| 460 | } |
||
| 461 | |||
| 462 | return(object) |
||
| 463 | } |
||
| 464 | |||
| 465 | #' @param value the name of main image |
||
| 466 | #' |
||
| 467 | #' @rdname vrMainImage |
||
| 468 | #' @order 4 |
||
| 469 | #' @export |
||
| 470 | setMethod("vrMainImage<-", "VoltRon", vrMainImageReplaceVoltRon) |
||
| 471 | |||
| 472 | #' @param value the name of main image |
||
| 473 | #' |
||
| 474 | #' @rdname vrMainSpatial |
||
| 475 | #' @order 4 |
||
| 476 | #' @export |
||
| 477 | setMethod("vrMainSpatial<-", "VoltRon", vrMainImageReplaceVoltRon) |
||
| 478 | |||
| 479 | vrMainImagevrAssay <- function(object) return(object@main_image) |
||
| 480 | |||
| 481 | #' @rdname vrMainImage |
||
| 482 | #' @order 3 |
||
| 483 | #' @export |
||
| 484 | setMethod("vrMainImage", "vrAssay", vrMainImagevrAssay) |
||
| 485 | |||
| 486 | #' @rdname vrMainImage |
||
| 487 | #' @order 3 |
||
| 488 | #' @export |
||
| 489 | setMethod("vrMainImage", "vrAssayV2", vrMainImagevrAssay) |
||
| 490 | |||
| 491 | #' @rdname vrMainSpatial |
||
| 492 | #' @order 3 |
||
| 493 | #' @export |
||
| 494 | setMethod("vrMainSpatial", "vrAssay", vrMainImagevrAssay) |
||
| 495 | |||
| 496 | #' @rdname vrMainSpatial |
||
| 497 | #' @order 3 |
||
| 498 | #' @export |
||
| 499 | setMethod("vrMainSpatial", "vrAssayV2", vrMainImagevrAssay) |
||
| 500 | |||
| 501 | #' @noRd |
||
| 502 | .replaceMainSpatial <- function(object, ignore = FALSE, value){ |
||
| 503 | |||
| 504 | if(length(value) %in% c(1,2)){ |
||
| 505 | |||
| 506 | # get channel name if exists in the value |
||
| 507 | if(length(value) == 2){ |
||
| 508 | channel <- value[2] |
||
| 509 | value <- value[1] |
||
| 510 | } else { |
||
| 511 | channel <- NULL |
||
| 512 | } |
||
| 513 | |||
| 514 | # set main spatial/image |
||
| 515 | if(value %in% vrSpatialNames(object)){ |
||
| 516 | object@main_image <- value |
||
| 517 | |||
| 518 | # set channel |
||
| 519 | if(!is.null(channel)) |
||
| 520 | vrMainChannel(object@image[[value]]) <- channel |
||
| 521 | |||
| 522 | } else { |
||
| 523 | if(ignore){ |
||
| 524 | warning("'",value,"' is not a spatial coordinate system in '", vrAssayNames(object),"'. Main system is still set to '", vrMainSpatial(object), "'") |
||
| 525 | } else { |
||
| 526 | stop("'",value,"' is not a spatial coordinate system in '", vrAssayNames(object),"'. Use ignore = TRUE for ignoring this message") |
||
| 527 | } |
||
| 528 | } |
||
| 529 | |||
| 530 | } else { |
||
| 531 | stop("The Main image is set by either: \n vrMainSpatial(object) <- c('<spatial name>', '<channel name>')\n or vrMainSpatial(object) <- '<spatial name>'") |
||
| 532 | } |
||
| 533 | |||
| 534 | return(object) |
||
| 535 | } |
||
| 536 | |||
| 537 | #' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored. |
||
| 538 | #' |
||
| 539 | #' @rdname vrMainImage |
||
| 540 | #' @order 5 |
||
| 541 | #' @export |
||
| 542 | setMethod("vrMainImage<-", "vrAssay", .replaceMainSpatial) |
||
| 543 | |||
| 544 | #' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored. |
||
| 545 | #' |
||
| 546 | #' @rdname vrMainImage |
||
| 547 | #' @order 5 |
||
| 548 | #' @export |
||
| 549 | setMethod("vrMainImage<-", "vrAssayV2", .replaceMainSpatial) |
||
| 550 | |||
| 551 | #' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored. |
||
| 552 | #' |
||
| 553 | #' @rdname vrMainSpatial |
||
| 554 | #' @order 5 |
||
| 555 | #' @export |
||
| 556 | setMethod("vrMainSpatial<-", "vrAssay", .replaceMainSpatial) |
||
| 557 | |||
| 558 | #' @param ignore if TRUE, the non-existing spatial coordinate system will be ignored. |
||
| 559 | #' |
||
| 560 | #' @rdname vrMainSpatial |
||
| 561 | #' @order 5 |
||
| 562 | #' @export |
||
| 563 | setMethod("vrMainSpatial<-", "vrAssayV2", .replaceMainSpatial) |
||
| 564 | |||
| 565 | vrImageNamesVoltRon <- function(object, assay = NULL){ |
||
| 566 | |||
| 567 | # sample metadata |
||
| 568 | sample.metadata <- SampleMetadata(object) |
||
| 569 | |||
| 570 | # get assay names |
||
| 571 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 572 | |||
| 573 | # if assay = all, give a summary |
||
| 574 | if(!is.null(assay)){ |
||
| 575 | if(assay == "all"){ |
||
| 576 | spatial_names <- unlist(lapply(assay_names, function(x) paste(vrSpatialNames(object[[x]]), collapse = ","))) |
||
| 577 | main_spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]]))) |
||
| 578 | spatial_names <- data.frame(sample.metadata[assay_names,], Spatial = spatial_names, Main = main_spatial_names) |
||
| 579 | return(spatial_names) |
||
| 580 | } |
||
| 581 | } |
||
| 582 | |||
| 583 | # unique names |
||
| 584 | spatial_names <- unique(unlist(lapply(assay_names, function(x) vrSpatialNames(object[[x]])))) |
||
| 585 | |||
| 586 | return(spatial_names) |
||
| 587 | } |
||
| 588 | |||
| 589 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 590 | #' 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 |
||
| 591 | #' |
||
| 592 | #' @rdname vrImageNames |
||
| 593 | #' |
||
| 594 | #' @export |
||
| 595 | setMethod("vrImageNames", "VoltRon", vrImageNamesVoltRon) |
||
| 596 | |||
| 597 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 598 | #' 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 |
||
| 599 | #' |
||
| 600 | #' @rdname vrSpatialNames |
||
| 601 | #' |
||
| 602 | #' @export |
||
| 603 | setMethod("vrSpatialNames", "VoltRon", vrImageNamesVoltRon) |
||
| 604 | |||
| 605 | vrImageNamesvrAssay <- function(object) names(object@image) |
||
| 606 | |||
| 607 | #' @rdname vrImageNames |
||
| 608 | #' |
||
| 609 | #' @export |
||
| 610 | setMethod("vrImageNames", "vrAssay", vrImageNamesvrAssay) |
||
| 611 | |||
| 612 | #' @rdname vrImageNames |
||
| 613 | #' |
||
| 614 | #' @export |
||
| 615 | setMethod("vrImageNames", "vrAssayV2", vrImageNamesvrAssay) |
||
| 616 | |||
| 617 | #' @rdname vrSpatialNames |
||
| 618 | #' |
||
| 619 | #' @export |
||
| 620 | setMethod("vrSpatialNames", "vrAssay", vrImageNamesvrAssay) |
||
| 621 | |||
| 622 | #' @rdname vrSpatialNames |
||
| 623 | #' |
||
| 624 | #' @export |
||
| 625 | setMethod("vrSpatialNames", "vrAssayV2", vrImageNamesvrAssay) |
||
| 626 | |||
| 627 | #### |
||
| 628 | ## Channel Methods #### |
||
| 629 | #### |
||
| 630 | |||
| 631 | vrMainChannelvrAssay <- function(object, name = NULL){ |
||
| 632 | if(is.null(name)){ |
||
| 633 | name <- vrMainSpatial(object) |
||
| 634 | } |
||
| 635 | return(vrMainChannel(object@image[[name]])) |
||
| 636 | } |
||
| 637 | |||
| 638 | #' @param name the name of the image |
||
| 639 | #' |
||
| 640 | #' @rdname vrMainChannel |
||
| 641 | #' @order 2 |
||
| 642 | #' @export |
||
| 643 | setMethod("vrMainChannel", "vrAssay", vrMainChannelvrAssay) |
||
| 644 | |||
| 645 | #' @param name the name of the image |
||
| 646 | #' |
||
| 647 | #' @rdname vrMainChannel |
||
| 648 | #' @order 2 |
||
| 649 | #' @export |
||
| 650 | setMethod("vrMainChannel", "vrAssayV2", vrMainChannelvrAssay) |
||
| 651 | |||
| 652 | vrMainChannelReplacevrAssay <- function(object, name = NULL, value){ |
||
| 653 | if(is.null(name)){ |
||
| 654 | name <- vrMainSpatial(object) |
||
| 655 | } |
||
| 656 | vrMainChannel(object@image[[name]]) <- value |
||
| 657 | return(object) |
||
| 658 | } |
||
| 659 | |||
| 660 | #' @param value the name of main channel |
||
| 661 | #' |
||
| 662 | #' @rdname vrMainChannel |
||
| 663 | #' @order 4 |
||
| 664 | #' @export |
||
| 665 | setMethod("vrMainChannel<-", "vrAssay", vrMainChannelReplacevrAssay) |
||
| 666 | |||
| 667 | #' @param value the name of main channel |
||
| 668 | #' |
||
| 669 | #' @rdname vrMainChannel |
||
| 670 | #' @order 4 |
||
| 671 | #' @export |
||
| 672 | setMethod("vrMainChannel<-", "vrAssayV2", vrMainChannelReplacevrAssay) |
||
| 673 | |||
| 674 | #' @rdname vrMainChannel |
||
| 675 | #' @order 3 |
||
| 676 | #' @export |
||
| 677 | setMethod("vrMainChannel", "vrImage", function(object){ |
||
| 678 | return(object@main_channel) |
||
| 679 | }) |
||
| 680 | |||
| 681 | #' @rdname vrMainChannel |
||
| 682 | #' @order 3 |
||
| 683 | #' @export |
||
| 684 | setMethod("vrMainChannel", "vrSpatial", function(object){ |
||
| 685 | return(object@main_channel) |
||
| 686 | }) |
||
| 687 | |||
| 688 | vrMainChannelReplacevrImage <- function(object, value){ |
||
| 689 | |||
| 690 | if(value %in% vrImageChannelNames(object)){ |
||
| 691 | object@main_channel <- value |
||
| 692 | } else { |
||
| 693 | stop("'",value,"' is not a channel name") |
||
| 694 | } |
||
| 695 | return(object) |
||
| 696 | } |
||
| 697 | |||
| 698 | #' @param value the name of main channel |
||
| 699 | #' |
||
| 700 | #' @rdname vrMainChannel |
||
| 701 | #' @method vrMainChannel<- vrImage |
||
| 702 | #' @order 5 |
||
| 703 | #' @export |
||
| 704 | setMethod("vrMainChannel<-", "vrImage", vrMainChannelReplacevrImage) |
||
| 705 | |||
| 706 | #' @param value the name of main channel |
||
| 707 | #' |
||
| 708 | #' @rdname vrMainChannel |
||
| 709 | #' @method vrMainChannel<- vrSpatial |
||
| 710 | #' @order 5 |
||
| 711 | #' @export |
||
| 712 | setMethod("vrMainChannel<-", "vrSpatial", vrMainChannelReplacevrImage) |
||
| 713 | |||
| 714 | vrImageChannelNamesVoltRon <- function(object, assay = NULL){ |
||
| 715 | |||
| 716 | # get assay names |
||
| 717 | if(is.null(assay)){ |
||
| 718 | assay_names <- vrAssayNames(object, assay = "all") |
||
| 719 | } else { |
||
| 720 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 721 | } |
||
| 722 | |||
| 723 | # sample metadata |
||
| 724 | sample.metadata <- SampleMetadata(object) |
||
| 725 | |||
| 726 | # get image names |
||
| 727 | spatial_names <- unlist(lapply(assay_names, function(x) vrMainSpatial(object[[x]]))) |
||
| 728 | |||
| 729 | # get channel names |
||
| 730 | image_channels <- unlist(lapply(assay_names, function(x) paste(vrImageChannelNames(object[[x]]), collapse = ","))) |
||
| 731 | |||
| 732 | # return data |
||
| 733 | image_data <- data.frame(sample.metadata[assay_names,], Spatial = spatial_names, Channels = image_channels) |
||
| 734 | |||
| 735 | # return |
||
| 736 | return(image_data) |
||
| 737 | } |
||
| 738 | |||
| 739 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 740 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 741 | #' |
||
| 742 | #' @rdname vrImageChannelNames |
||
| 743 | #' |
||
| 744 | #' @export |
||
| 745 | setMethod("vrImageChannelNames", "VoltRon", vrImageChannelNamesVoltRon) |
||
| 746 | |||
| 747 | vrImageChannelNamesvrAssay <- function(object, name = NULL){ |
||
| 748 | |||
| 749 | if(is.null(name)){ |
||
| 750 | name <- vrMainSpatial(object) |
||
| 751 | } else { |
||
| 752 | if(!name %in% vrSpatialNames(object)) |
||
| 753 | stop(name, " is not among any image in this vrAssay object") |
||
| 754 | } |
||
| 755 | |||
| 756 | return(vrImageChannelNames(object@image[[name]])) |
||
| 757 | } |
||
| 758 | |||
| 759 | #' @param name the key of the image |
||
| 760 | #' |
||
| 761 | #' @rdname vrImageChannelNames |
||
| 762 | #' |
||
| 763 | #' @export |
||
| 764 | setMethod("vrImageChannelNames", "vrAssay", vrImageChannelNamesvrAssay) |
||
| 765 | |||
| 766 | #' @param name the key of the image |
||
| 767 | #' |
||
| 768 | #' @rdname vrImageChannelNames |
||
| 769 | #' |
||
| 770 | #' @export |
||
| 771 | setMethod("vrImageChannelNames", "vrAssayV2", vrImageChannelNamesvrAssay) |
||
| 772 | |||
| 773 | vrImageChannelNamesvrImage <- function(object){ |
||
| 774 | if(is.null(names(object@image))){ |
||
| 775 | return("No Channels or Images are found!") |
||
| 776 | } else{ |
||
| 777 | return(names(object@image)) |
||
| 778 | } |
||
| 779 | } |
||
| 780 | |||
| 781 | #' @rdname vrImageChannelNames |
||
| 782 | #' |
||
| 783 | #' @export |
||
| 784 | setMethod("vrImageChannelNames", "vrImage", vrImageChannelNamesvrImage) |
||
| 785 | |||
| 786 | #' @rdname vrImageChannelNames |
||
| 787 | #' |
||
| 788 | #' @export |
||
| 789 | setMethod("vrImageChannelNames", "vrSpatial", vrImageChannelNamesvrImage) |
||
| 790 | |||
| 791 | #### |
||
| 792 | ## Managing Images #### |
||
| 793 | #### |
||
| 794 | |||
| 795 | resizeImageVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, size = NULL){ |
||
| 796 | |||
| 797 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 798 | |||
| 799 | for(assy in assay_names){ |
||
| 800 | object[[assy]] <- resizeImage(object[[assy]], name = name, reg = reg, size = size) |
||
| 801 | } |
||
| 802 | return(object) |
||
| 803 | } |
||
| 804 | |||
| 805 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 806 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 807 | #' @param name the name of the image |
||
| 808 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested |
||
| 809 | #' @param size the width of the resized image |
||
| 810 | #' |
||
| 811 | #' @rdname resizeImage |
||
| 812 | #' |
||
| 813 | #' @export |
||
| 814 | setMethod("resizeImage", "VoltRon", resizeImageVoltRon) |
||
| 815 | |||
| 816 | resizeImagevrAssay <- function(object, name = NULL, reg = FALSE, size = NULL){ |
||
| 817 | |||
| 818 | # get main image is main_image is null |
||
| 819 | if(is.null(name)) { |
||
| 820 | name <- object@main_image |
||
| 821 | } |
||
| 822 | |||
| 823 | # check registered image |
||
| 824 | if(reg){ |
||
| 825 | if(!paste0(name, "_reg") %in% vrSpatialNames(object)){ |
||
| 826 | warning("There are no registered images with name ", name, "!") |
||
| 827 | } else { |
||
| 828 | name <- paste0(name, "_reg") |
||
| 829 | } |
||
| 830 | } |
||
| 831 | |||
| 832 | # check main image |
||
| 833 | if(!name %in% vrSpatialNames(object)){ |
||
| 834 | stop(name, " is not among any image in this vrAssay object") |
||
| 835 | } |
||
| 836 | |||
| 837 | object@image[[name]] <- resizeImage(object@image[[name]], size = size) |
||
| 838 | |||
| 839 | # return |
||
| 840 | return(object) |
||
| 841 | } |
||
| 842 | |||
| 843 | #' @rdname resizeImage |
||
| 844 | #' |
||
| 845 | #' @export |
||
| 846 | setMethod("resizeImage", "vrAssay", resizeImagevrAssay) |
||
| 847 | |||
| 848 | #' @rdname resizeImage |
||
| 849 | #' |
||
| 850 | #' @export |
||
| 851 | setMethod("resizeImage", "vrAssayV2", resizeImagevrAssay) |
||
| 852 | |||
| 853 | resizeImagevrImage <- function(object, size = NULL){ |
||
| 854 | |||
| 855 | # sizefactor |
||
| 856 | sizefactor <- image_info(vrImages(object))$width |
||
| 857 | |||
| 858 | # check size |
||
| 859 | if(is.null(size)) |
||
| 860 | size = sizefactor |
||
| 861 | if(!is.numeric(size)) |
||
| 862 | stop("width size should be numeric") |
||
| 863 | if(!all.equal(size, as.integer(size)) & size > 0) |
||
| 864 | stop("width size should be a positive integer") |
||
| 865 | if(size < 100) |
||
| 866 | stop("width size cannot be less than 100px") |
||
| 867 | |||
| 868 | # resize coordinates |
||
| 869 | vrCoordinates(object) <- (vrCoordinates(object)*size)/sizefactor |
||
| 870 | |||
| 871 | # resize segments |
||
| 872 | vrSegments(object) <- lapply(vrSegments(object), function(x) { |
||
| 873 | x[,c("x", "y")] <- x[,c("x", "y")]*size/sizefactor |
||
| 874 | if(any(colnames(x) %in% c("rx", "ry"))){ |
||
| 875 | x[,c("rx", "ry")] <- x[,c("rx", "ry")]*size/sizefactor |
||
| 876 | } |
||
| 877 | return(x) |
||
| 878 | }) |
||
| 879 | |||
| 880 | # resize images |
||
| 881 | size <- paste0(size,"x") |
||
| 882 | image_names <- vrImageChannelNames(object) |
||
| 883 | for(img in image_names){ |
||
| 884 | img_data <- object@image[[img]] |
||
| 885 | if(inherits(img_data, "Image_Array")){ |
||
| 886 | stop("Currently modulateImage only works on in-memory images!") |
||
| 887 | } else { |
||
| 888 | img_data <- magick::image_read(img_data) |
||
| 889 | img_data <- magick::image_resize(img_data, geometry = size) |
||
| 890 | object@image[[img]] <- magick::image_data(img_data) |
||
| 891 | } |
||
| 892 | } |
||
| 893 | |||
| 894 | # return |
||
| 895 | return(object) |
||
| 896 | } |
||
| 897 | |||
| 898 | #' @rdname resizeImage |
||
| 899 | #' |
||
| 900 | #' @importFrom magick image_info image_resize image_read image_data |
||
| 901 | #' @export |
||
| 902 | setMethod("resizeImage", "vrImage", resizeImagevrImage) |
||
| 903 | |||
| 904 | #' @rdname resizeImage |
||
| 905 | #' |
||
| 906 | #' @importFrom magick image_info image_resize image_read image_data |
||
| 907 | #' @export |
||
| 908 | setMethod("resizeImage", "vrSpatial", resizeImagevrImage) |
||
| 909 | |||
| 910 | modulateImageVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, channel = NULL, |
||
| 911 | brightness = 100, saturation = 100, hue = 100, force = FALSE){ |
||
| 912 | |||
| 913 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 914 | |||
| 915 | for(assy in assay_names){ |
||
| 916 | object[[assy]] <- modulateImage(object[[assy]], name = name, reg = reg, channel = channel, brightness = brightness, |
||
| 917 | saturation = saturation, hue = hue, force = force) |
||
| 918 | } |
||
| 919 | return(object) |
||
| 920 | } |
||
| 921 | |||
| 922 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 923 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 924 | #' @param name the name of the image |
||
| 925 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested |
||
| 926 | #' @param channel the name of the channel associated with the image |
||
| 927 | #' @param brightness modulation of brightness as percentage of the current value (100 for no change) |
||
| 928 | #' @param saturation modulation of saturation as percentage of the current value (100 for no change) |
||
| 929 | #' @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) |
||
| 930 | #' @param force if TRUE, all channels will be modulated given no specific channel name |
||
| 931 | #' |
||
| 932 | #' @rdname modulateImage |
||
| 933 | #' |
||
| 934 | #' @export |
||
| 935 | setMethod("modulateImage", "VoltRon", modulateImageVoltRon) |
||
| 936 | |||
| 937 | modulateImagevrAssay <- function(object, name = NULL, reg = FALSE, channel = NULL, |
||
| 938 | brightness = 100, saturation = 100, hue = 100, force = FALSE){ |
||
| 939 | |||
| 940 | # check name |
||
| 941 | if(is.null(name)) { |
||
| 942 | name <- object@main_image |
||
| 943 | } |
||
| 944 | |||
| 945 | # get registered image |
||
| 946 | if(reg){ |
||
| 947 | if(!paste0(name, "_reg") %in% vrSpatialNames(object)){ |
||
| 948 | warning("There are no registered images with name ", name, "!") |
||
| 949 | } else { |
||
| 950 | name <- paste0(name, "_reg") |
||
| 951 | } |
||
| 952 | } |
||
| 953 | |||
| 954 | # check main image |
||
| 955 | if(!name %in% vrSpatialNames(object)){ |
||
| 956 | stop(name, " is not among any image in this vrAssay object") |
||
| 957 | } |
||
| 958 | |||
| 959 | object@image[[name]] <- modulateImage(object@image[[name]], channel = channel, brightness = brightness, |
||
| 960 | saturation = saturation, hue = hue, force = force) |
||
| 961 | |||
| 962 | # return |
||
| 963 | return(object) |
||
| 964 | } |
||
| 965 | |||
| 966 | #' @rdname modulateImage |
||
| 967 | #' |
||
| 968 | #' @export |
||
| 969 | setMethod("modulateImage", "vrAssay", modulateImagevrAssay) |
||
| 970 | |||
| 971 | #' @rdname modulateImage |
||
| 972 | #' |
||
| 973 | #' @export |
||
| 974 | setMethod("modulateImage", "vrAssayV2", modulateImagevrAssay) |
||
| 975 | |||
| 976 | modulateImagevrImage <- function(object, channel = NULL, brightness = 100, saturation = 100, hue = 100, force = FALSE){ |
||
| 977 | |||
| 978 | # check main_channels |
||
| 979 | if(is.null(channel) && (length(vrImageChannelNames(object)) > 1 && !force)){ |
||
| 980 | 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!") |
||
| 981 | } |
||
| 982 | |||
| 983 | # get channel names |
||
| 984 | if(is.null(channel)){ |
||
| 985 | channel <- vrImageChannelNames(object) |
||
| 986 | } |
||
| 987 | |||
| 988 | # modulate image |
||
| 989 | for(img in channel){ |
||
| 990 | img_data <- object@image[[img]] |
||
| 991 | if(inherits(img_data, "Image_Array")){ |
||
| 992 | stop("Currently modulateImage only works on in-memory images!") |
||
| 993 | } else { |
||
| 994 | img_data <- magick::image_read(img_data) |
||
| 995 | # img_data <- getImage(object, name = img) |
||
| 996 | img_data <- magick::image_modulate(img_data, brightness = brightness, saturation = saturation, hue = hue) |
||
| 997 | object@image[[img]] <- magick::image_data(img_data) |
||
| 998 | } |
||
| 999 | } |
||
| 1000 | |||
| 1001 | # return |
||
| 1002 | return(object) |
||
| 1003 | } |
||
| 1004 | |||
| 1005 | #' @rdname modulateImage |
||
| 1006 | #' |
||
| 1007 | #' @importFrom magick image_info image_modulate |
||
| 1008 | #' @export |
||
| 1009 | setMethod("modulateImage", "vrImage", modulateImagevrImage) |
||
| 1010 | |||
| 1011 | #' @rdname modulateImage |
||
| 1012 | #' |
||
| 1013 | #' @importFrom magick image_info image_modulate |
||
| 1014 | #' @export |
||
| 1015 | setMethod("modulateImage", "vrSpatial", modulateImagevrImage) |
||
| 1016 | |||
| 1017 | combineChannelsVoltRon <- function(object, assay = NULL, name = NULL, reg = FALSE, |
||
| 1018 | channels = NULL, colors = NULL, channel_key = "combined"){ |
||
| 1019 | |||
| 1020 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1021 | |||
| 1022 | for(assy in assay_names){ |
||
| 1023 | object[[assy]] <- combineChannels(object[[assy]], name = name, reg = reg, |
||
| 1024 | channels = channels, colors = colors, channel_key = channel_key) |
||
| 1025 | } |
||
| 1026 | return(object) |
||
| 1027 | } |
||
| 1028 | |||
| 1029 | |||
| 1030 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1031 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1032 | #' @param name the name of the image |
||
| 1033 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainSpatial}) is requested |
||
| 1034 | #' @param channels the name of the channel associated with the image |
||
| 1035 | #' @param colors the colors associated with each channel |
||
| 1036 | #' @param channel_key the name of the new channel name |
||
| 1037 | #' |
||
| 1038 | #' @rdname combineChannels |
||
| 1039 | #' |
||
| 1040 | #' @export |
||
| 1041 | setMethod("combineChannels", "VoltRon", combineChannelsVoltRon) |
||
| 1042 | |||
| 1043 | combineChannelsvrAssay <- function(object, name = NULL, reg = FALSE, channels = NULL, colors = NULL, channel_key = "combined"){ |
||
| 1044 | |||
| 1045 | # check name |
||
| 1046 | if(is.null(name)) { |
||
| 1047 | name <- object@main_image |
||
| 1048 | } |
||
| 1049 | |||
| 1050 | # get registered image |
||
| 1051 | if(reg){ |
||
| 1052 | if(!paste0(name, "_reg") %in% vrSpatialNames(object)){ |
||
| 1053 | warning("There are no registered images with name ", name, "!") |
||
| 1054 | } else { |
||
| 1055 | name <- paste0(name, "_reg") |
||
| 1056 | } |
||
| 1057 | } |
||
| 1058 | |||
| 1059 | # check main image |
||
| 1060 | if(!name %in% vrSpatialNames(object)){ |
||
| 1061 | stop(name, " is not among any image in this vrAssay object") |
||
| 1062 | } |
||
| 1063 | |||
| 1064 | object@image[[name]] <- combineChannels(object@image[[name]], channels = channels, colors = colors, channel_key = channel_key) |
||
| 1065 | |||
| 1066 | # return |
||
| 1067 | return(object) |
||
| 1068 | } |
||
| 1069 | |||
| 1070 | #' @rdname combineChannels |
||
| 1071 | #' |
||
| 1072 | #' @export |
||
| 1073 | setMethod("combineChannels", "vrAssay", combineChannelsvrAssay) |
||
| 1074 | |||
| 1075 | #' @rdname combineChannels |
||
| 1076 | #' |
||
| 1077 | #' @export |
||
| 1078 | setMethod("combineChannels", "vrAssayV2", combineChannelsvrAssay) |
||
| 1079 | |||
| 1080 | combineChannelsvrImage <- function(object, channels = NULL, colors = NULL, channel_key = "combined"){ |
||
| 1081 | |||
| 1082 | # check channel names |
||
| 1083 | if(is.null(channels)){ |
||
| 1084 | stop("No channel names were given") |
||
| 1085 | } else { |
||
| 1086 | if(any(!channels %in% vrImageChannelNames(object))){ |
||
| 1087 | warning("Some channel names do not match with the existing channels.") |
||
| 1088 | } |
||
| 1089 | } |
||
| 1090 | |||
| 1091 | # check colors |
||
| 1092 | if(is.null(colors)){ |
||
| 1093 | stop("No colors were given") |
||
| 1094 | } |
||
| 1095 | if(length(colors) != length(channels)){ |
||
| 1096 | stop("The length of colors do not match with the length of channels.") |
||
| 1097 | } |
||
| 1098 | |||
| 1099 | # configure channel and color names |
||
| 1100 | colors <- colors[channels %in% vrImageChannelNames(object)] |
||
| 1101 | channels <- channels[channels %in% vrImageChannelNames(object)] |
||
| 1102 | names(colors) <- channels |
||
| 1103 | |||
| 1104 | # get images and colorize |
||
| 1105 | channel_list <- list() |
||
| 1106 | composite_image <- NULL |
||
| 1107 | for(img in channels){ |
||
| 1108 | channel_img <- vrImages(object, channel = img) |
||
| 1109 | color_rgb <- grDevices::col2rgb(colors[img])[,1] |
||
| 1110 | imagedata <- as.numeric(magick::image_data(channel_img, channels = "rgb")) |
||
| 1111 | imagedata[,,1] <- imagedata[,,1] * (color_rgb[1]/255) |
||
| 1112 | imagedata[,,2] <- imagedata[,,2] * (color_rgb[2]/255) |
||
| 1113 | imagedata[,,3] <- imagedata[,,3] * (color_rgb[3]/255) |
||
| 1114 | channel_img <- magick::image_read(imagedata) |
||
| 1115 | if(is.null(composite_image)){ |
||
| 1116 | composite_image <- channel_img |
||
| 1117 | } else{ |
||
| 1118 | composite_image <- magick::image_composite(channel_img, composite_image, operator = "Plus") |
||
| 1119 | } |
||
| 1120 | } |
||
| 1121 | |||
| 1122 | # combine channels |
||
| 1123 | vrImages(object, channel = channel_key) <- composite_image |
||
| 1124 | |||
| 1125 | # return |
||
| 1126 | return(object) |
||
| 1127 | } |
||
| 1128 | |||
| 1129 | #' @rdname combineChannels |
||
| 1130 | #' |
||
| 1131 | #' @importFrom magick image_read image_data image_composite |
||
| 1132 | #' @importFrom grDevices col2rgb |
||
| 1133 | #' |
||
| 1134 | #' @export |
||
| 1135 | setMethod("combineChannels", "vrImage", combineChannelsvrImage) |
||
| 1136 | |||
| 1137 | #' @rdname combineChannels |
||
| 1138 | #' |
||
| 1139 | #' @export |
||
| 1140 | setMethod("combineChannels", "vrSpatial", combineChannelsvrImage) |
||
| 1141 | |||
| 1142 | #### |
||
| 1143 | # Other Methods #### |
||
| 1144 | #### |
||
| 1145 | |||
| 1146 | #' @rdname vrSpatialPoints |
||
| 1147 | #' @order 4 |
||
| 1148 | #' |
||
| 1149 | #' @export |
||
| 1150 | setMethod("vrSpatialPoints", "vrImage", function(object) { |
||
| 1151 | return(rownames(vrCoordinates(object))) |
||
| 1152 | }) |
||
| 1153 | |||
| 1154 | #' @rdname vrSpatialPoints |
||
| 1155 | #' @order 4 |
||
| 1156 | #' |
||
| 1157 | #' @export |
||
| 1158 | setMethod("vrSpatialPoints", "vrSpatial", function(object) { |
||
| 1159 | return(rownames(vrCoordinates(object))) |
||
| 1160 | }) |
||
| 1161 | |||
| 1162 | vrSpatialPointsReplacevrImage <- function(object, value) { |
||
| 1163 | |||
| 1164 | # coordinates |
||
| 1165 | if(length(rownames(object@coords)) != length(value)){ |
||
| 1166 | stop("The number of spatial points is not matching with the input") |
||
| 1167 | } else { |
||
| 1168 | rownames(object@coords) <- value |
||
| 1169 | } |
||
| 1170 | |||
| 1171 | # segments |
||
| 1172 | if(length(object@segments) > 0){ |
||
| 1173 | if(length(names(object@segments)) != length(value)){ |
||
| 1174 | stop("The number of spatial points is not matching with the input") |
||
| 1175 | } else { |
||
| 1176 | names(object@segments) <- value |
||
| 1177 | } |
||
| 1178 | } |
||
| 1179 | |||
| 1180 | # return |
||
| 1181 | return(object) |
||
| 1182 | } |
||
| 1183 | |||
| 1184 | #' @param value new spatial points |
||
| 1185 | #' |
||
| 1186 | #' @rdname vrSpatialPoints |
||
| 1187 | #' @order 9 |
||
| 1188 | #' @export |
||
| 1189 | setMethod("vrSpatialPoints<-", "vrImage", vrSpatialPointsReplacevrImage) |
||
| 1190 | |||
| 1191 | #' @param value new spatial points |
||
| 1192 | #' |
||
| 1193 | #' @rdname vrSpatialPoints |
||
| 1194 | #' @order 9 |
||
| 1195 | #' @export |
||
| 1196 | setMethod("vrSpatialPoints<-", "vrSpatial", vrSpatialPointsReplacevrImage) |
||
| 1197 | |||
| 1198 | #' @rdname vrCoordinates |
||
| 1199 | #' @order 3 |
||
| 1200 | #' @export |
||
| 1201 | setMethod("vrCoordinates", "vrImage", function(object) { |
||
| 1202 | return(object@coords) |
||
| 1203 | }) |
||
| 1204 | |||
| 1205 | #' @rdname vrCoordinates |
||
| 1206 | #' @order 3 |
||
| 1207 | #' @export |
||
| 1208 | setMethod("vrCoordinates", "vrSpatial", function(object) { |
||
| 1209 | return(object@coords) |
||
| 1210 | }) |
||
| 1211 | |||
| 1212 | vrCoordinatesRepkacevrImage <- function(object, value) { |
||
| 1213 | |||
| 1214 | # get coordinates |
||
| 1215 | coords <- vrCoordinates(object) |
||
| 1216 | |||
| 1217 | # stop if the rownames are not matching |
||
| 1218 | if(any(vapply(rownames(value),is.null, logical(1)))) |
||
| 1219 | stop("Provided coordinates data does not have cell/spot/ROI names") |
||
| 1220 | |||
| 1221 | if(!all(rownames(value) %in% rownames(coords))) |
||
| 1222 | stop("Cant overwrite coordinates, non-existing cells/spots/ROIs!") |
||
| 1223 | |||
| 1224 | # stop if the colnames there are more than two columns |
||
| 1225 | if(ncol(value) == 2){ |
||
| 1226 | value <- cbind(value, 0) |
||
| 1227 | colnames(value) <- c("x", "y", "z") |
||
| 1228 | } else if(ncol(value) == 3){ |
||
| 1229 | colnames(value) <- c("x", "y", "z") |
||
| 1230 | } else { |
||
| 1231 | stop("Please make sure that the coordinates matrix have only two or three columns: for x and y coordinates") |
||
| 1232 | } |
||
| 1233 | |||
| 1234 | methods::slot(object = object, name = 'coords') <- value |
||
| 1235 | return(object) |
||
| 1236 | } |
||
| 1237 | |||
| 1238 | #' @rdname vrCoordinates |
||
| 1239 | #' @order 6 |
||
| 1240 | #' @importFrom methods slot |
||
| 1241 | #' |
||
| 1242 | #' @export |
||
| 1243 | setMethod("vrCoordinates<-", "vrImage", vrCoordinatesRepkacevrImage) |
||
| 1244 | |||
| 1245 | #' @rdname vrCoordinates |
||
| 1246 | #' @order 6 |
||
| 1247 | #' @importFrom methods slot |
||
| 1248 | #' |
||
| 1249 | #' @export |
||
| 1250 | setMethod("vrCoordinates<-", "vrSpatial", vrCoordinatesRepkacevrImage) |
||
| 1251 | |||
| 1252 | #' @rdname vrSegments |
||
| 1253 | #' @order 4 |
||
| 1254 | #' @export |
||
| 1255 | setMethod("vrSegments", "vrImage", function(object) { |
||
| 1256 | return(object@segments) |
||
| 1257 | }) |
||
| 1258 | |||
| 1259 | #' @rdname vrSegments |
||
| 1260 | #' @order 4 |
||
| 1261 | #' @export |
||
| 1262 | setMethod("vrSegments", "vrSpatial", function(object) { |
||
| 1263 | return(object@segments) |
||
| 1264 | }) |
||
| 1265 | |||
| 1266 | vrSegmentsReplacevrImage <- function(object, value) { |
||
| 1267 | |||
| 1268 | # get coordinates |
||
| 1269 | segts <- vrSegments(object) |
||
| 1270 | |||
| 1271 | # stop if the names are not matching |
||
| 1272 | if(any(vapply(names(value),is.null, logical(1)))) |
||
| 1273 | stop("Provided coordinates data does not have cell/spot/ROI names") |
||
| 1274 | |||
| 1275 | if(!all(names(value) %in% names(segts))) |
||
| 1276 | stop("Cant overwrite coordinates, non-existing cells/spots/ROIs!") |
||
| 1277 | |||
| 1278 | methods::slot(object = object, name = 'segments') <- value |
||
| 1279 | return(object) |
||
| 1280 | } |
||
| 1281 | |||
| 1282 | #' @rdname vrSegments |
||
| 1283 | #' @order 7 |
||
| 1284 | #' @importFrom methods slot |
||
| 1285 | #' @export |
||
| 1286 | setMethod("vrSegments<-", "vrImage", vrSegmentsReplacevrImage) |
||
| 1287 | |||
| 1288 | #' @rdname vrSegments |
||
| 1289 | #' @order 7 |
||
| 1290 | #' @importFrom methods slot |
||
| 1291 | #' @export |
||
| 1292 | setMethod("vrSegments<-", "vrSpatial", vrSegmentsReplacevrImage) |
||
| 1293 | |||
| 1294 | #### |
||
| 1295 | # Demultiplex Images #### |
||
| 1296 | #### |
||
| 1297 | |||
| 1298 | #' demuxVoltRon |
||
| 1299 | #' |
||
| 1300 | #' Subsetting/demultiplexing of the VoltRon Object using interactive shiny app |
||
| 1301 | #' |
||
| 1302 | #' @param object a VoltRon object |
||
| 1303 | #' @param max.pixel.size the initial width of the object image |
||
| 1304 | #' @param use.points.only use spatial points instead of the reference image |
||
| 1305 | #' @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} |
||
| 1306 | #' |
||
| 1307 | #' @import shiny |
||
| 1308 | #' @importFrom shinyjs useShinyjs |
||
| 1309 | #' @importFrom magick image_scale image_info image_ggplot |
||
| 1310 | #' @importFrom ggplot2 geom_rect |
||
| 1311 | #' @importFrom dplyr filter add_row tibble |
||
| 1312 | #' @importFrom ggrepel geom_label_repel |
||
| 1313 | #' |
||
| 1314 | demuxVoltRon <- function(object, max.pixel.size = 1200, use.points.only = FALSE, shiny.options = list(launch.browser = getOption("shiny.launch.browser", interactive()))) |
||
| 1315 | { |
||
| 1316 | # check if there are only one assay in the object |
||
| 1317 | sample.metadata <- SampleMetadata(object) |
||
| 1318 | |||
| 1319 | if(length(unique(sample.metadata$Layer)) > 1) |
||
| 1320 | stop("You can only subset a single VoltRon layer at a time") |
||
| 1321 | |||
| 1322 | # get image |
||
| 1323 | images <- vrImages(object[[vrAssayNames(object)]], as.raster = TRUE) |
||
| 1324 | if(!inherits(images, "Image_Array")){ |
||
| 1325 | images <- magick::image_read(images) |
||
| 1326 | } |
||
| 1327 | |||
| 1328 | # scale |
||
| 1329 | imageinfo <- getImageInfo(images) |
||
| 1330 | scale_factor <- 1 |
||
| 1331 | if(imageinfo$width > max.pixel.size){ |
||
| 1332 | scale_factor <- imageinfo$width/max.pixel.size |
||
| 1333 | } |
||
| 1334 | if(use.points.only){ |
||
| 1335 | object_small <- resizeImage(object, size = max.pixel.size) |
||
| 1336 | image_info_small <- magick::image_info(vrImages(object_small)) |
||
| 1337 | coords <- as.data.frame(vrCoordinates(object_small, reg = FALSE)) |
||
| 1338 | pl <- ggplot() + geom_point(aes_string(x = "x", y = "y"), coords, size = 1.5, color = "black") + |
||
| 1339 | theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank(), |
||
| 1340 | axis.line=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), |
||
| 1341 | legend.margin = margin(0,0,0,0), plot.margin = unit( c(0,0,0,0),"in")) + |
||
| 1342 | coord_fixed() |
||
| 1343 | } else { |
||
| 1344 | pl <- plotImage(images, max.pixel.size = max.pixel.size) |
||
| 1345 | } |
||
| 1346 | |||
| 1347 | # get the ui and server |
||
| 1348 | |||
| 1349 | # UI #### |
||
| 1350 | ui <- fluidPage( |
||
| 1351 | |||
| 1352 | # use javascript extensions for Shiny |
||
| 1353 | shinyjs::useShinyjs(), |
||
| 1354 | |||
| 1355 | # sidebar |
||
| 1356 | sidebarLayout(position = "left", |
||
| 1357 | |||
| 1358 | # Side bar |
||
| 1359 | sidebarPanel( |
||
| 1360 | tags$style(make_css(list('.well', 'margin', '7%'))), |
||
| 1361 | |||
| 1362 | # Interface |
||
| 1363 | fluidRow( |
||
| 1364 | column(12,h4("Interactive Subsetting")) |
||
| 1365 | ), |
||
| 1366 | |||
| 1367 | # Buttons |
||
| 1368 | fluidRow( |
||
| 1369 | column(12,shiny::actionButton("resetpoints", "Remove Box")), |
||
| 1370 | br(), |
||
| 1371 | column(12,shiny::actionButton("addbox", "Add Box")), |
||
| 1372 | br() |
||
| 1373 | ), |
||
| 1374 | |||
| 1375 | # instructions |
||
| 1376 | h4("How to use"), |
||
| 1377 | p(style="font-size: 12px;", strong("Single-L-hold-drag:"), "Select area"), |
||
| 1378 | p(style="font-size: 12px;", strong("Add Box"), " to set a new subset"), |
||
| 1379 | p(style="font-size: 12px;", strong("Remove Box"), " to reset the box"), |
||
| 1380 | br(), |
||
| 1381 | |||
| 1382 | # Subsets |
||
| 1383 | fluidRow( |
||
| 1384 | column(12,h4("Selected Subsets")), |
||
| 1385 | uiOutput("textbox_ui"), |
||
| 1386 | br() |
||
| 1387 | ), |
||
| 1388 | |||
| 1389 | # Subsets |
||
| 1390 | fluidRow( |
||
| 1391 | column(12,shiny::actionButton("done", "Done")) |
||
| 1392 | ), |
||
| 1393 | br(), |
||
| 1394 | |||
| 1395 | # panel options |
||
| 1396 | width = 3, |
||
| 1397 | ), |
||
| 1398 | |||
| 1399 | mainPanel( |
||
| 1400 | |||
| 1401 | # main image |
||
| 1402 | br(), |
||
| 1403 | br(), |
||
| 1404 | fluidRow( |
||
| 1405 | plotOutput("cropped_image", |
||
| 1406 | height = "1000px", |
||
| 1407 | brush = brushOpts( |
||
| 1408 | id = "plot_brush", fill = "green", |
||
| 1409 | resetOnNew = TRUE |
||
| 1410 | )), |
||
| 1411 | ), |
||
| 1412 | |||
| 1413 | # panel options |
||
| 1414 | width = 9 |
||
| 1415 | ) |
||
| 1416 | ) |
||
| 1417 | ) |
||
| 1418 | |||
| 1419 | # Server #### |
||
| 1420 | server <- function(input, output, session) { |
||
| 1421 | |||
| 1422 | ## Importing images and variables #### |
||
| 1423 | |||
| 1424 | # selected corner list |
||
| 1425 | selected_corners_list_image <- reactiveVal(dplyr::tibble(box = character())) |
||
| 1426 | selected_corners_list <- reactiveVal(list()) |
||
| 1427 | |||
| 1428 | ## Region Annotators #### |
||
| 1429 | |||
| 1430 | ### Text Box Management #### |
||
| 1431 | |||
| 1432 | # Reactive value to store the number of textboxes |
||
| 1433 | textboxes <- reactiveVal(numeric(0)) |
||
| 1434 | |||
| 1435 | # Initialize textbox values if n > 0, get already existing segments |
||
| 1436 | textbox_values <- reactiveValues() |
||
| 1437 | |||
| 1438 | # Dynamically generate UI for textboxes and remove buttons |
||
| 1439 | output$textbox_ui <- renderUI({ |
||
| 1440 | lapply(textboxes(), function(i) { |
||
| 1441 | column(12, |
||
| 1442 | textInputwithButton(textinputId = paste0("sample", i), label = paste0("Subset ", i), |
||
| 1443 | buttoninputId = paste0("remove", i), value = isolate(textbox_values[[paste0("sample", i)]]), |
||
| 1444 | onclick = sprintf('Shiny.setInputValue("remove", %d)', i)) |
||
| 1445 | ) |
||
| 1446 | }) |
||
| 1447 | }) |
||
| 1448 | |||
| 1449 | # Observe changes in each textbox to update their values |
||
| 1450 | observe({ |
||
| 1451 | lapply(textboxes(), function(i) { |
||
| 1452 | observeEvent(input[[paste0("sample", i)]], { |
||
| 1453 | textbox_values[[paste0("sample", i)]] <- isolate(input[[paste0("sample", i)]]) |
||
| 1454 | }, ignoreNULL = FALSE) |
||
| 1455 | }) |
||
| 1456 | }) |
||
| 1457 | |||
| 1458 | ### Reset box #### |
||
| 1459 | observeEvent(input$resetpoints, { |
||
| 1460 | session$resetBrush("plot_brush") |
||
| 1461 | }) |
||
| 1462 | |||
| 1463 | ### Remove box #### |
||
| 1464 | |||
| 1465 | # Observe event to remove textbox when the button is clicked |
||
| 1466 | observeEvent(input$remove, { |
||
| 1467 | |||
| 1468 | # remove one point |
||
| 1469 | selected_corners_list(selected_corners_list()[!(textboxes() == as.numeric(isolate(input$remove)))]) |
||
| 1470 | |||
| 1471 | # Update the reactive value to remove the textbox |
||
| 1472 | textboxes(setdiff(textboxes(), as.numeric(isolate(input$remove)))) |
||
| 1473 | |||
| 1474 | # Remove the value from textbox_values |
||
| 1475 | textbox_values[[paste0("sample", as.numeric(input$remove))]] <- NULL |
||
| 1476 | |||
| 1477 | }, ignoreInit = TRUE) |
||
| 1478 | |||
| 1479 | ### Add box #### |
||
| 1480 | observeEvent(input$addbox, { |
||
| 1481 | |||
| 1482 | # get corners |
||
| 1483 | brush <- input$plot_brush |
||
| 1484 | |||
| 1485 | # add a box if brush is active |
||
| 1486 | if(!is.null(brush)){ |
||
| 1487 | |||
| 1488 | # corners |
||
| 1489 | corners <- data.frame(x = c(brush$xmin, brush$xmax), |
||
| 1490 | y = c(brush$ymax, brush$ymin)) |
||
| 1491 | |||
| 1492 | # record corners |
||
| 1493 | selected_corners_list(c(selected_corners_list(), list(corners))) |
||
| 1494 | |||
| 1495 | # adjust corners |
||
| 1496 | corners <- corners*scale_factor |
||
| 1497 | corners <- FromBoxToCrop(corners, imageinfo) |
||
| 1498 | |||
| 1499 | # add to box list |
||
| 1500 | selected_corners_list_image() %>% |
||
| 1501 | dplyr::add_row(box = corners) %>% |
||
| 1502 | selected_corners_list_image() |
||
| 1503 | |||
| 1504 | # reset box |
||
| 1505 | session$resetBrush("plot_brush") |
||
| 1506 | |||
| 1507 | # add buttons |
||
| 1508 | new_id <- if (length(textboxes()) == 0) 1 else max(textboxes()) + 1 |
||
| 1509 | textboxes(c(textboxes(), new_id)) |
||
| 1510 | textbox_values[[paste0("sample", new_id)]] <- "" |
||
| 1511 | } |
||
| 1512 | }) |
||
| 1513 | |||
| 1514 | ## Main observable #### |
||
| 1515 | observe({ |
||
| 1516 | |||
| 1517 | # output image |
||
| 1518 | output[["cropped_image"]] <- renderPlot({ |
||
| 1519 | |||
| 1520 | # visualize already selected boxes |
||
| 1521 | if(length(selected_corners_list()) > 0){ |
||
| 1522 | for (i in seq_len(length(selected_corners_list()))){ |
||
| 1523 | corners <- apply(as.matrix(selected_corners_list()[[i]]),2,as.numeric) |
||
| 1524 | if(nrow(corners) > 1){ |
||
| 1525 | corners <- as.data.frame(rbind(cbind(corners[1,1], corners[seq_len(2),2]), cbind(corners[2,1], corners[rev(seq_len(2)),2]))) |
||
| 1526 | colnames(corners) <- c("x", "y") |
||
| 1527 | pl <- pl + ggplot2::geom_polygon(aes(x = x, y = y), data = corners, alpha = 0.3, fill = "green", color = "black") |
||
| 1528 | |||
| 1529 | } |
||
| 1530 | } |
||
| 1531 | } |
||
| 1532 | |||
| 1533 | # put labels of the already selected polygons |
||
| 1534 | if(length(selected_corners_list()) > 0){ |
||
| 1535 | for (i in seq_len(length(selected_corners_list()))){ |
||
| 1536 | corners <- selected_corners_list()[[i]] |
||
| 1537 | corners <- as.data.frame(rbind(cbind(corners[1,1], corners[seq_len(2),2]), cbind(corners[2,1], corners[rev(seq_len(2)),2]))) |
||
| 1538 | corners <- data.frame(x = mean(corners[,1]), y = max(corners[,2]), sample = paste("Subset ", isolate(textboxes()[i]))) |
||
| 1539 | pl <- pl + |
||
| 1540 | ggrepel::geom_label_repel(mapping = aes(x = x, y = y, label = sample), data = corners, |
||
| 1541 | size = 5, direction = "y", nudge_y = 6, box.padding = 0, label.padding = 1, seed = 1, color = "red") |
||
| 1542 | } |
||
| 1543 | } |
||
| 1544 | |||
| 1545 | # return graph |
||
| 1546 | pl |
||
| 1547 | }) |
||
| 1548 | }) |
||
| 1549 | |||
| 1550 | ## Done #### |
||
| 1551 | |||
| 1552 | # show "Done" if a region is selected already |
||
| 1553 | observe({ |
||
| 1554 | if(nrow(selected_corners_list_image()) > 0){ |
||
| 1555 | shinyjs::show(id = "done") |
||
| 1556 | } else { |
||
| 1557 | shinyjs::hide(id = "done") |
||
| 1558 | } |
||
| 1559 | }) |
||
| 1560 | |||
| 1561 | # observe for done and return the list of objects |
||
| 1562 | observeEvent(input$done, { |
||
| 1563 | if(nrow(selected_corners_list_image()) > 0){ |
||
| 1564 | subsets <- list() |
||
| 1565 | box_list <- selected_corners_list_image() |
||
| 1566 | |||
| 1567 | # collect labels |
||
| 1568 | sample_names <- vapply(seq_len(length(box_list$box)), function(i) input[[paste0("sample",i)]], character(1)) |
||
| 1569 | |||
| 1570 | # check if sample names are present |
||
| 1571 | if(any(sample_names == "")) { |
||
| 1572 | showNotification("Some subsets have blank (empty!) sample names.") |
||
| 1573 | } else{ |
||
| 1574 | for(i in seq_len(length(box_list$box))){ |
||
| 1575 | temp <- subsetVoltRon(object, image = box_list$box[i]) |
||
| 1576 | temp$Sample <- sample_names[i] |
||
| 1577 | subsets[[sample_names[i]]] <- temp |
||
| 1578 | } |
||
| 1579 | stopApp(list(subsets = subsets, subset_info_list = box_list)) |
||
| 1580 | } |
||
| 1581 | |||
| 1582 | } else { |
||
| 1583 | showNotification("You have not selected a subset yet!") |
||
| 1584 | } |
||
| 1585 | }) |
||
| 1586 | } |
||
| 1587 | |||
| 1588 | # configure options |
||
| 1589 | shiny.options <- configure_shiny_options(shiny.options) |
||
| 1590 | |||
| 1591 | # run app |
||
| 1592 | shiny::runApp( |
||
| 1593 | shiny::shinyApp(ui, server, options = list(host = shiny.options[["host"]], port = shiny.options[["port"]], launch.browser = shiny.options[["launch.browser"]]), |
||
| 1594 | onStart = function() { |
||
| 1595 | onStop(function() { |
||
| 1596 | }) |
||
| 1597 | }) |
||
| 1598 | ) |
||
| 1599 | } |
||
| 1600 | |||
| 1601 | |||
| 1602 | #' FromBoxToCrop |
||
| 1603 | #' |
||
| 1604 | #' get magick crop information from a dataframe of box corners |
||
| 1605 | #' |
||
| 1606 | #' @param corners topleft and bottomright coordinates of bounding box |
||
| 1607 | #' @param imageinfo info of the image |
||
| 1608 | #' |
||
| 1609 | #' @noRd |
||
| 1610 | FromBoxToCrop <- function(corners, imageinfo){ |
||
| 1611 | |||
| 1612 | corners <- apply(corners,2,ceiling) |
||
| 1613 | |||
| 1614 | # fix for limits |
||
| 1615 | corners[1,1] <- ifelse(corners[1,1] < 0, 0, corners[1,1]) |
||
| 1616 | corners[1,1] <- ifelse(corners[1,1] > imageinfo$width, imageinfo$width, corners[1,1]) |
||
| 1617 | corners[2,1] <- ifelse(corners[2,1] < 0, 0, corners[2,1]) |
||
| 1618 | corners[2,1] <- ifelse(corners[2,1] > imageinfo$width, imageinfo$width, corners[2,1]) |
||
| 1619 | corners[1,2] <- ifelse(corners[1,2] < 0, 0, corners[1,2]) |
||
| 1620 | corners[1,2] <- ifelse(corners[1,2] > imageinfo$height, imageinfo$height, corners[1,2]) |
||
| 1621 | corners[2,2] <- ifelse(corners[2,2] < 0, 0, corners[2,2]) |
||
| 1622 | corners[2,2] <- ifelse(corners[2,2] > imageinfo$height, imageinfo$height, corners[2,2]) |
||
| 1623 | |||
| 1624 | # get crop info |
||
| 1625 | corners <- paste0(abs(corners[2,1]-corners[1,1]), "x", |
||
| 1626 | abs(corners[2,2]-corners[1,2]), "+", |
||
| 1627 | min(corners[,1]), "+", imageinfo$height - max(corners[,2])) |
||
| 1628 | |||
| 1629 | # corners |
||
| 1630 | return(corners) |
||
| 1631 | } |
||
| 1632 | |||
| 1633 | #' FromSegmentToCrop |
||
| 1634 | #' |
||
| 1635 | #' get magick crop information from coordinates of a segment |
||
| 1636 | #' |
||
| 1637 | #' @param segment coordinates of a segment |
||
| 1638 | #' @param imageinfo info of the image |
||
| 1639 | #' |
||
| 1640 | #' @export |
||
| 1641 | FromSegmentToCrop <- function(segment, imageinfo){ |
||
| 1642 | |||
| 1643 | # make box from segment coordinates |
||
| 1644 | corners <- matrix(c(0,0,0,0), nrow = 2, ncol = 2) |
||
| 1645 | corners[1,1] <- min(segment[,1]) |
||
| 1646 | corners[2,1] <- max(segment[,1]) |
||
| 1647 | corners[1,2] <- max(segment[,2]) |
||
| 1648 | corners[2,2] <- min(segment[,2]) |
||
| 1649 | |||
| 1650 | # get crop from box |
||
| 1651 | corners <- FromBoxToCrop(corners, imageinfo) |
||
| 1652 | |||
| 1653 | # corners |
||
| 1654 | return(corners) |
||
| 1655 | } |
||
| 1656 |