version 0.1.0

DESCRIPTION

@@ -0,0 +1,28 @@
+Package: SSIMmap
+Title: The Structural Similarity Index Measure for Maps
+Version: 0.1.0
+Authors@R: c(
+  person(given="Hui Jeong (Hailyee)", family="Ha", email="hha24@uwo.ca", role = c("aut", "cre"),comment = c(ORCID = "0000-0002-5229-4528")), 
+  person(given="Jed", family="Long", email="jed.long@uwo.ca", role="aut", comment = c(ORCID = "0000-0003-3961-3085")))
+Description: Extends the classical SSIM method proposed by 'Wang', 'Bovik', 'Sheikh', and 'Simoncelli'(2004) <doi:10.1109/TIP.2003.819861>. 
+  for irregular lattice-based maps and raster images.
+  The geographical SSIM method incorporates well-developed 'geographically weighted summary statistics'('Brunsdon', 'Fotheringham' and 'Charlton' 2002) <doi:10.1016/S0198-9715(01)00009-6> 
+  with an adaptive bandwidth kernel function for irregular lattice-based maps.
+Depends: R (>= 3.5.0)
+License: MIT + file LICENSE
+Encoding: UTF-8
+LazyData: true
+RoxygenNote: 7.2.3
+Imports: stats, scales, dplyr, terra, ggplot2, sf, knitr
+Suggests: RColorBrewer, testthat (>= 3.0.0), rmarkdown
+URL: https://github.com/Hailyee-Ha/SSIMmap
+BugReports: https://github.com/Hailyee-Ha/SSIMmap/issues
+VignetteBuilder: knitr
+NeedsCompilation: no
+Packaged: 2023-08-22 15:34:09 UTC; hailyeeha
+Author: Hui Jeong (Hailyee) Ha [aut, cre]
+    (<https://orcid.org/0000-0002-5229-4528>),
+  Jed Long [aut] (<https://orcid.org/0000-0003-3961-3085>)
+Maintainer: Hui Jeong (Hailyee) Ha <hha24@uwo.ca>
+Repository: CRAN
+Date/Publication: 2023-08-22 18:40:02 UTC

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: SSIMmap authors

MD5

@@ -0,0 +1,29 @@
+24b6d72f33f8add344de41b819642465 *DESCRIPTION
+14e813b08e1c9579bd569065d24cab52 *LICENSE
+5fc0eb7e03324858cfabc9263dfc5d8a *NAMESPACE
+bfef7e5e108650d28dc9223dedd0b147 *R/Toronto.R
+e79d2c234171cd23d7ce43734addc5cf *R/global.R
+e62fc6c0eaf8a3ad8f36dda0b3ad0da5 *R/gw_dist.R
+4ef5ffa003e98439d351d623b963912d *R/gw_weight_ad.R
+616f6e46ef455ae29b28a8975fb44f76 *R/gwss_new.R
+371a312329de7e90b5bffc31350e3f90 *R/ssim_bandwidth.R
+da8043733edbe1ac61d9f29a4eece395 *R/ssim_constant.R
+0ec275717336b67ea35ef3782357a2e8 *R/ssim_polygon.R
+2ceae0c1f4586d2b7277c6cbf270e52e *R/ssim_raster.R
+778109128b88b47102b950c4919f80ad *README.md
+4e89428feb369f2aa09fb4cb6ff2b196 *build/vignette.rds
+422377bda91f2fff97d6a31ced70bb47 *data/Toronto.rda
+06a840ad288893cfe7b23c6bb1a1778a *inst/doc/Introduction_to_SSIMmap.R
+0fed5882048bb6ab7166d8c98e002250 *inst/doc/Introduction_to_SSIMmap.Rmd
+844de27ddfcb0b15259b80bf6b4023c7 *inst/doc/Introduction_to_SSIMmap.html
+62dc5a9b186acf5bf6e38127d3911ee9 *inst/ex/groups2nm.tif
+27a25b640a8b67b7fccf7111a81bd783 *inst/ex/single2nm.tif
+9d85583d8073d4163ccc4584e085c5d7 *man/Toronto.Rd
+6ab054461c75f706bd1cff71e02a75cc *man/figures/logo.png
+0547fe970c6cb445778431325cee5511 *man/ssim_bandwidth.Rd
+92b32a6cae121d4e4cc2005fc31fc2a7 *man/ssim_constant.Rd
+15e6eca31df2e6af291c902d3f3a7b30 *man/ssim_polygon.Rd
+2d16c0b650ff92b9c7b3a949c490cedb *man/ssim_raster.Rd
+da0acf9a508a37e7ec362d2ea063640e *tests/testthat.R
+225e3812b897786befc574f805c96dc2 *tests/testthat/test-SSIMmap.R
+0fed5882048bb6ab7166d8c98e002250 *vignettes/Introduction_to_SSIMmap.Rmd

NAMESPACE

@@ -0,0 +1,27 @@
+# Generated by roxygen2: do not edit by hand
+
+export(ssim_bandwidth)
+export(ssim_constant)
+export(ssim_polygon)
+export(ssim_raster)
+importFrom(dplyr,contains)
+importFrom(dplyr,select)
+importFrom(ggplot2,geom_line)
+importFrom(ggplot2,geom_rect)
+importFrom(ggplot2,geom_text)
+importFrom(ggplot2,geom_vline)
+importFrom(ggplot2,ggplot)
+importFrom(ggplot2,labs)
+importFrom(knitr,kable)
+importFrom(scales,rescale)
+importFrom(sf,st_centroid)
+importFrom(sf,st_coordinates)
+importFrom(sf,st_crs)
+importFrom(sf,st_read)
+importFrom(stats,cov.wt)
+importFrom(stats,sd)
+importFrom(stats,var)
+importFrom(terra,crop)
+importFrom(terra,focal)
+importFrom(terra,global)
+importFrom(terra,rast)

R/Toronto.R

@@ -0,0 +1,12 @@
+#' Sample polygon data of Toronto
+#'
+#' A sf(simple feature) containing geometric boundaries of Toronto DAs(Dissemination Area) with their codes.
+#'
+#' \describe{
+#'   \item{DAUID}{Dissemination Area ID}
+#'   \item{CIMD_SDD}{Factor score of CIMD(The Canadian Index of Multiple Deprivation) social deprivation dimension}
+#'   \item{PP_SDD}{Principal score of Pampalon social deprivation dimension}
+#'   \item{P_commute}{Percentage of households who commute within census subdivision (CSD) of residence }
+#'   \item{geometry}{the geometry column for counties(CRS: NAD83)}
+#' }
+"Toronto"

R/global.R

@@ -0,0 +1 @@
+utils::globalVariables(c("Bias", "Variance", "Bandwidth"))

R/gw_dist.R

@@ -0,0 +1,7 @@
+
+gw.dist <- function(dp, sp, focus=0) {
+  focus_point <- sp[focus, ]
+  dists <- sqrt((dp[,1] - focus_point[1])^2 + (dp[,2] - focus_point[2])^2)
+  dists
+}
+

R/gw_weight_ad.R

@@ -0,0 +1,38 @@
+
+
+gw.weight<- function(vdist,bw){
+
+  if (is.matrix(vdist)){
+    nr <- nrow(vdist)
+    dn <- bw/nr
+    if(dn<=1)
+    {
+      rnk<-apply(vdist,2,rank,ties.method='first')
+      bw<- vdist[rnk==bw]
+    }
+    else
+    {
+      bw <- dn*apply(vdist,2,max)
+    }
+    if(length(bw)>0)
+      wgt<- exp(vdist^2 / (-2 * bw^2))
+    else
+      wgt <- diag(1, dim(vdist)[1], dim(vdist)[2])
+  }else{
+    nr <- length(vdist)
+    dn <- bw/nr
+    if(dn<=1)
+    {
+      rnk<-rank(vdist,ties.method='first')
+      cond<- which(rnk <= bw)
+      bw<- vdist[rnk==bw]
+    }
+    else
+    {
+      bw <- dn*max(vdist)
+    }
+      wgt<- exp(vdist^2 / (-2 * bw^2))
+  wgt
+  }
+}
+

R/gwss_new.R

@@ -0,0 +1,81 @@
+#' @importFrom sf st_crs st_centroid st_coordinates
+#' @importFrom stats cov.wt
+
+gwss_new<-function (data, vars,bw){
+  p4s <- st_crs(data)$proj4string
+  options(sf_warn_centroid_attrs = FALSE)
+  dp.locat <- st_centroid(data)
+  dp.locat <- data.frame(st_coordinates(dp.locat))
+  dp.locat<-as.matrix(dp.locat)
+  sp.locat <- st_centroid(data)
+  sp.locat <- data.frame(st_coordinates(sp.locat))
+  sp.locat<-as.matrix(sp.locat)
+
+  shape<-data
+  data <- as.data.frame(data)
+  dp.n <- nrow(data)
+  sp.n <- nrow(sp.locat)
+
+  if (missing(vars))
+    stop("Variables input error")
+  if (missing(bw) || bw <= 0)
+    stop("Bandwidth is not specified incorrectly")
+  len.var <- length(vars)
+  col.nm <- colnames(data)
+  var.idx <- match(vars, col.nm)[!is.na(match(vars, col.nm))]
+  if (length(var.idx) == 0)
+    stop("Variables input doesn't match with data")
+  x <- data[, var.idx]
+  x <- as.matrix(x)
+  var.nms <- names(data)[var.idx]
+  var.n <- ncol(x)
+  if (len.var > var.n)
+    warning("Invalid variables have been specified, please check them again!")
+  local.mean <- matrix(numeric(var.n * sp.n), ncol = var.n)
+  standard.deviation <- matrix(numeric(var.n * sp.n), ncol = var.n)
+  LVar <- matrix(numeric(var.n * sp.n), ncol = var.n)
+  cov.nms <- c()
+  cov.mat <- c()
+  if (var.n > 1) {
+    cov.mat <- matrix(numeric((var.n - 1) * var.n * sp.n/2),
+                      nrow = sp.n)
+  }
+
+  for (i in 1:sp.n) {
+    dist.vi <- gw.dist(dp.locat, sp.locat, focus = i)
+    W.i <- as.matrix(gw.weight(dist.vi, bw), nrow = 1)
+    sum.w <- sum(W.i)
+    Wi <- W.i/sum.w
+    Wi <- as.numeric(Wi)
+    local.mean[i, ] <- Wi %*% x
+    for (j in 1:var.n) {
+      LVar[i, j] <- Wi %*% ((x[, j] - local.mean[i, j])^2)
+      standard.deviation[i, j] <- sqrt(LVar[i, j])
+    }
+      tag <- 0
+      tag <- tag + 1
+      cov.mat[i, tag] <- cov.wt(cbind(x[, 1], x[, 2]), wt =Wi)$cov[1, 2]
+     }
+
+
+  colnames(local.mean) <- paste(var.nms, "LM", sep = "_")
+  colnames(standard.deviation) <- paste(var.nms, "LSD", sep = "_")
+  colnames(LVar) <- paste(var.nms, "LVar", sep = "_")
+  if (var.n > 1) {
+    for (i in 1:(var.n - 1)) {
+      for (j in (i + 1):var.n) {
+        cov.v1v2 <- paste("Cov", paste(var.nms[i], var.nms[j],
+                                       sep = "."), sep = "_")
+        cov.nms <- c(cov.nms, cov.v1v2)
+      }
+    }
+    colnames(cov.mat) <- cov.nms
+  }
+  res.df <- data.frame(local.mean, standard.deviation,
+                           LVar, cov.mat)
+
+  rownames(res.df) <- rownames(sp.locat)
+
+ gwresult<- cbind(shape,res.df)
+ return(gwresult)
+}