R/click_sample.R

In AGAuffret/HistMapR: Rapid digitization of historical land-use maps in R

click_sample <-
  function(in.raster, cats = NULL, npoints = 10, print.values = F, type = "p", plot.cols = T, ...){
    
    require(terra)
    
    # Stop and provide a useful error message if the orig.raster object is not found or not a SpatRaster object
    
    if(!class(in.raster)[1] == "SpatRaster"){
      stop("Error: Input must be a SpatRaster object")
    }
    
    if(is.null(cats) == TRUE){
      stop("Error: Categories not specified")
    }
    
    if(any(names(in.raster) != c("red", "green", "blue"))){
      stop("Error: Bands incorrectly named - please rename and if necessary reorder to 'red', 'green' and 'blue'")
    }
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
    # first generate the sample table
    
    # Make sure the plotting window is ok
    par(mfrow = c(1,1))
    
    # create an empty data frame to insert values into
    vals <- data.frame()
    
    # Loop through the categories
    for(i in cats){
      
      # tell the user to be patient
      cat("\nOpening plot window, please wait... \n")
      
      # plot the raster
      plotRGB(in.raster,1,2,3)
      
      # print user instruction
      cat("Click on ", npoints, " areas of class ", i,  "\n",sep = "")
      
      clickvals <- data.frame(click(in.raster, n = npoints, show = print.values, type = type))
      
      # insert an identifier for the category being sampled
      clickvals$category <- i
      
      # inform user that this category is now finished
      cat("Category ", i, " sampling complete\n\n")
      
      # append to output dataframe
      vals <- rbind(vals, clickvals)
      
      # Close the plot window so that the user does not mistakenly register a click for the wrong category
      dev.off()
    }
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
    # second generate the summary of the sampled points
    
    # create a new dataframe to take the output values
    thresh2 <- data.frame(matrix(ncol = 13, nrow = length(cats))) 
    
    # name the columns
    colnames(thresh2) <- c("cat", "Rmax", "Rmean", "Rmin", "Rsd", "Gmax", "Gmean", "Gmin", "Gsd", "Bmax", "Bmean", "Bmin", "Bsd")
    
    # loop through the categories
    for(i in cats){
      
      # read in the subset of the sample table that corresponds to the category i
      workdat <- subset(vals, subset = (category == i))
      
      # extract the max, mean, min and sd for each band within the sample
      
      thresh2[match(i, cats),] <- c(i, 
                                    max(workdat$red),
                                    mean(workdat$red),
                                    min(workdat$red),
                                    sd(workdat$red),
                                    max(workdat$green),
                                    mean(workdat$green),
                                    min(workdat$green),
                                    sd(workdat$green),
                                    max(workdat$blue),
                                    mean(workdat$blue),
                                    min(workdat$blue),
                                    sd(workdat$blue))
    }
    
    # make numeric
    thresh2[,c(2:13)] <- as.numeric(as.character(unlist(thresh2[,c(2:13)])))
    
    
    # calculate the standard error for each band
    thresh2$Rse <- thresh2$Rsd/sqrt(npoints)
    thresh2$Gse <- thresh2$Gsd/sqrt(npoints)
    thresh2$Bse <- thresh2$Bsd/sqrt(npoints)
    
    
    
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
    # Finally, if requested, generate the plot of the sampled points
    
    if(plot.cols == T){
      
      colplot <- plot_colour_table(thresh2, ...)
      
    }else{
      print("Plot not drawn")
      
      colplot <- "Plot not drawn"
    }
    
    # return the desired output
    return(list(sample.table = vals,colour.summary = thresh2, colour.plot = colplot))
  }