version 0.1.3

DESCRIPTION

@@ -0,0 +1,22 @@
+Package: sad
+Title: Verify the Scale, Anisotropy and Direction of Weather Forecasts
+Version: 0.1.3
+Authors@R: 
+    person(given = "Sebastian",
+           family = "Buschow",
+           role = c("aut", "cre"),
+           email = "s6sebusc@uni-bonn.de",
+           comment = c(ORCID = "0000-0003-4750-361X"))
+Description: Implementation of the wavelet-based spatial verification method of Buschow and Friederichs "SAD: Verifying the Scale, Anisotropy and Direction of precipitation forecasts" (2020, submitted to QJRMS). Forecasts and Observations are transformed by a decimated or redundant dual-tree complex wavelet transform to analyze the spatial scale, degree of anisotropy and preferred direction in each field. These structural attributes are compared by a series of scores. An experimental algorithm for the correction of these errors is included as well.
+License: MIT + file LICENSE
+Imports: emdist
+Depends: dualtrees
+Encoding: UTF-8
+LazyData: false
+RoxygenNote: 6.1.1
+NeedsCompilation: no
+Packaged: 2020-11-02 09:43:31 UTC; s6sebusc
+Author: Sebastian Buschow [aut, cre] (<https://orcid.org/0000-0003-4750-361X>)
+Maintainer: Sebastian Buschow <s6sebusc@uni-bonn.de>
+Repository: CRAN
+Date/Publication: 2020-11-06 16:30:02 UTC

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2020
+COPYRIGHT HOLDER: Sebastian Buschow

MD5

@@ -0,0 +1,19 @@
+60d718f504be5e06951a24f76cd0f944 *DESCRIPTION
+3aa3337d9909e6727b6a5273157b5d1a *LICENSE
+562d7534cc0d19d00a9f6d63ae4c2f8d *NAMESPACE
+d0d02d9d86fd4a82a8cda142c2982006 *R/data.R
+a74e86afa0ad6553bb7c6aabe0d9f9e8 *R/lowlevel.R
+651a58de7dbc6182857e66b1b40a0a78 *R/plotfunctions.R
+e93bd481c8272d2ccb915cd868f41b09 *R/sadcorrect.R
+4e85d2c3fb8fcc7a6a8046b7e74224e5 *R/sadverif.R
+e01d44645bba935c0ee4940ba0fae425 *R/scores.R
+a002b526c81a682ad2f15cae55e1b891 *data/rrain.rda
+d8645178f3bced3a5206ea67d02d8224 *man/getpareto.Rd
+001ce3be45718ea17ea2847e983d740e *man/hemd.Rd
+247f74ec98d994e8b3ad633cf9a6db53 *man/prepare_sad.Rd
+857d98cd30644ac9bd702ba01f7b7ff2 *man/raincols.Rd
+dc21822f0905877914cef0533698d69b *man/rrain.Rd
+79fcba07fe089de6ec3176e7302090a5 *man/sadcorrect.Rd
+3628a5f662183b55f4c7b96524a80c47 *man/sadforecast.Rd
+cb2e6cf2b2bc6a918d9ab9956a391f7d *man/sadverif.Rd
+472b09cbca3c581412cd18be9ddec66b *man/semd.Rd

NAMESPACE

@@ -0,0 +1,14 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(plot,sadforecast)
+S3method(plot,sadverif)
+S3method(summary,sadverif)
+export(as.sadforecast)
+export(getpareto)
+export(hemd)
+export(prepare_sad)
+export(raincols)
+export(sadcorrect)
+export(sadverif)
+export(semd)
+import(dualtrees)

R/data.R

@@ -0,0 +1,18 @@
+#' Random Rain
+#'
+#' Randomly simulated synthetic rain fields with Matern covariances
+#'
+#' @docType data
+#'
+#' @usage data(rrain)
+#'
+#' @format A \code{4x10x128x128} matrix
+#'
+#' @keywords datasets
+#'
+#' @details These fields were used in Buschow et al. (2019) <doi:10.5194/gmd-12-3401-2019>. The first array corresponds to the four model configurations from that paper (different roughness nu and scale sc), the second dimension contains ten realizations for each model.
+#' @source simulated using the 'RandomFields' package, code available at <10.5281/zenodo.3257511>
+#'
+#' @examples
+#' data(rrain)
+"rrain"  

R/lowlevel.R

@@ -0,0 +1,125 @@
+#' class for a list of forecasts
+#'
+#' check that a list of forecasts fulfills all requirements to be verified by our method
+#' @param x a list of 2 or more 2D matrices with equal sizes and no missing or inifinite values
+#' @param mfrow vector with the number of rows and columns you would like in the plot
+#' @param col color scale for the plot
+#' @param ... further arguments passed to \code{image}
+#' @return an object of class \code{sadforecast} 
+#' @details \code{as.sadforecast} does nothing except check that everything is as it should be, add the attributes that can be changed by \code{prepare_sad} and provide a method for quick plots of the data.
+#' @examples
+#' data( rrain )
+#' ra <- list( rrain[1,1,,], rrain[4,5,,], rrain[2,7,,] )
+#' ra <- as.sadforecast(ra)
+#' plot(ra)
+#' @name sadforecast
+NULL
+
+#' @rdname sadforecast
+#' @export
+as.sadforecast <- function(x){
+    # check that we got a list
+    if( !is.list(x) ) stop( "please provide observation and forecasts as a list of matrices" )
+
+    # check that we got at least one pair
+    n <- length(x)
+    if( n<2 ) stop( "need at least two fields to compare" )
+
+    # check the dimensions
+    dims <- unlist( lapply(x, function(x) length(dim(x))) )
+    if( any( dims != 2 ) ) stop( "all inputs must be 2D matrices" )
+    nx <- unlist( lapply( x, nrow ) )
+    ny <- unlist( lapply( x, ncol ) )
+    if( any( nx[-1] != nx[1] ) | any( ny[-1] != ny[1] )  ) stop( "all inputs must have the same dimensions" )
+
+    # check that we got no missing values
+    if( any( is.na( unlist( x ) ) ) )      stop( "no missing values allowed" ) 
+    if( any( !is.finite( unlist( x ) ) ) ) stop( "no infinite values allowed" ) 
+
+    # maybe add names
+    if( is.null( names(x) ) ) names(x) <- c( "obs", paste0( "f", 1:(n-1) ) )
+
+    # add attributes if they aren't given already
+    defaults <- list( log=FALSE, px=1:nx[1], py=1:ny[1], rsm=0, xmin=-Inf, boundaries="none" )
+    for( n in names( defaults ) ){
+        if( is.null( attr(x, n) ) ) attr( x, n ) <- defaults[[n]]
+    }
+
+    return( structure( x, class="sadforecast" ) )
+}
+
+#' prepare a sad forecast for verification
+#'
+#' remove small values, apply log-transform, smooth borders, handle boundary conditions
+#' @param x a list of 2 or more 2D matrices with equal sizes and no missing or inifinite values, as required by \code{as.sadforecast}
+#' @param xmin values smaller than \code{xmin} are set to zero
+#' @param log  logical, do you want to log-transfrom the data? (recommended for precipitation)
+#' @param rsm  number of pixels which are linearly smoothed at the edge
+#' @param Nx   size to which the data is extended in x-direction
+#' @param Ny   size to which the data is extended in y-direction
+#' @param boundaries how to handle the boundary conditions, either "pad", "mirror" or "periodic"
+#' @return an object of class \code{sadforecast} which has been prepared in the desired way.
+#' @details the positions within the extended field where the original field resides are output as attributes "px", "py" of the result. The other input parameters are saved as attributes of the result as well.
+#' @examples
+#' data( rrain )
+#' ra <- list( rrain[2,4,,], rrain[3,9,,] )
+#' ra <- prepare_sad( ra, rsm=0, Nx=256, boundaries="mirror", log=FALSE )
+#' plot(ra)
+#' @export
+prepare_sad <- function( x, xmin=0.1, log=TRUE, rsm=0, Nx=NULL, Ny=NULL, boundaries="pad" ){
+    x <- as.sadforecast( x )
+    old_att <- attributes( x )
+
+    if( is.null(Nx) ) Nx <- nrow( x[[1]] )
+    if( is.null(Ny) ) Ny <- ncol( x[[1]] )
+
+    # remove small values
+    x <- lapply(x, function(x) x*1*(x>=xmin) )
+    # smooth the boundaries
+    x <- lapply(x, dualtrees::smooth_borders, r=rsm)
+
+    # log or no?
+    if( log & !old_att$log ) logfun <- function(x) log2( x + xmin ) else logfun <- identity
+    # select boundary type
+    bound <- switch( boundaries, 
+                     mirror=dualtrees::put_in_mirror, 
+                     pad=dualtrees::pad, 
+                     periodic=dualtrees::period_bc,
+                     stop( "unknown boundaries, you can use 'mirror', 'pad' or 'periodic'" )
+                    )
+    # remember where we were in the original field
+    bc <- bound( logfun(x[[1]]), N=Nx, Ny=Ny )
+    # apply boundaries and maybe logarithm
+    x  <- lapply( x, function(x) bound( logfun(x), N=Nx, Ny=Ny )$res )
+
+    # set attributes
+    class( x ) <- "sadforecast"
+    attr( x, "px" ) <- bc$px
+    attr( x, "py" ) <- bc$py
+    attr( x, "xmin" ) <- max( xmin, old_att$xmin )
+    if(log) attr( x, "log" )  <- TRUE
+    attr( x, "rsm" ) <- rsm
+    attr( x, "boundaries" ) <- boundaries
+    return( x )
+}
+
+#' rain color scale
+#'
+#' eight shades of blue used in \code{plot.sadforecast}
+#' @export
+raincols <- c( "#FCFCFC", "#CAD5EB", "#97AFD9", "#608AC8", "#3267A5", "#214671", "#112641", "#040404" )
+
+angdif <- function(x,y){
+    d <- x - y
+    if( d > 90 )  d <- d - 180
+    if( d < -90 ) d <- d + 180
+    return(d)
+}
+
+
+checkJ <- function(J, Nx, Ny){
+    if( J < 1 ) stop( "you have to use at least one scale (J>=1)" )
+    N    <- min( Nx, Ny )
+    Jmax <- floor( log2( N ) )
+    if( J > Jmax ) stop( paste0( "J must be no greater than ", Jmax ) )
+}

R/plotfunctions.R

@@ -0,0 +1,21 @@
+
+
+#' @rdname sadforecast
+#' @export
+plot.sadforecast <- function(x,  mfrow=NULL, col=NULL,  ...){
+    if( is.null(col) ) col <- raincols
+    oldpar <- graphics::par( no.readonly=TRUE )
+    on.exit( graphics::par(oldpar) )
+
+    nc <- ceiling( sqrt( length(x) ) )
+    nr <- ceiling( length(x)/nc )
+    if( is.null(mfrow) ) mfrow <- c(nr,nc)
+
+    graphics::par( mfrow=mfrow, mar=c(1,1,2,1) )
+    for( i in 1:length(x) ){
+        graphics::image( x[[i]], col=col, xaxt="n", yaxt="n", xlab="", ylab="", 
+                         useRaster=TRUE, main=names(x)[i], ... )
+    }
+
+
+}

R/sadcorrect.R

@@ -0,0 +1,99 @@
+#' correct structure errors
+#'
+#' use the inverse 'dtcwt' to correct errors in scale, anisotropy and direction
+#' @param x a list of equally sized matrices, the first element is assumed to be the observation
+#' @param xmin values smaller than \code{xmin} are set to zero
+#' @param log  logical, do you want to log-transfrom the data? (recommended for precipitation)
+#' @param rsm  number of pixels which are linearly smoothed at the edge
+#' @param Nx   size to which the data is extended in x-direction, has to be a whole power of 2
+#' @param Ny   size to which the data is extended in y-direction, has to be a whole power of 2
+#' @param J    largest scale considered
+#' @param boundaries how to handle the boundary conditions, either "pad", "mirror" or "periodic"
+#' @param direction if \code{TRUE}, scale and direction are corrected, otherwise only scale
+#' @return an object of class \code{sadforecast}
+#' @details The algorithm performs the following steps:
+#' \enumerate{
+#'    \item remove values below \code{xmin}
+#'    \item if \code{log=TRUE} log-transform all fields
+#'    \item  set all fields to zero mean, unit variance
+#'    \item apply \code{dtcwt} to all fields
+#'    \item loop over forecasts and scales. If \code{direction=TRUE} loop over the six directions. Multiply forecast energy at each location by the ratio of total observed energy to total forecast energy at that scale (and possibly direction)
+#'    \item apply \code{idtcwt} to all forecasts
+#'    \item reset means and variance of the forecasts to their original values
+#'    \item if \code{log=TRUE} invert the log-transform 
+#'    \item return the list of corrected fields
+#'}
+#' @examples
+#' data(rrain)
+#' ra   <- as.sadforecast( list( rrain[2,1,,], rrain[3,1,,], rrain[3,2,,], rrain[3,3,,] ) )
+#' ra_c <- sadcorrect( ra, rsm=10 )
+#' plot(ra_c)
+#' @export
+sadcorrect <- function( x, xmin=0.1, log=TRUE, rsm=0, Nx=NULL, Ny=NULL, J=NULL, boundaries="pad", direction=TRUE ){
+
+    # check the input
+    x   <- as.sadforecast( x )
+    n   <- length( x )
+    nam <- names( x )
+
+    # get defaults for the dimensions etc
+    if( is.null( Nx ) ) Nx <- 2**ceiling( log2( max( dim( x[[1]] ) )  ) )
+    if( is.null( Ny ) ) Ny <- Nx
+    if( is.null( J ) ) J <- log2( min(Nx,Ny) ) - 3
+
+    # check that J is valid
+    checkJ( J, Nx, Ny )
+
+    # remember the original observation
+    obs0 <- x[[1]]
+
+    # handle thresholding, log, boundaries
+    x <- prepare_sad( x, xmin, log, rsm, Nx, Ny, boundaries )
+
+    # standardize the margins
+    xm    <- lapply( x, mean )
+    xsd   <- lapply( x, stats::sd )
+    for( i in 1:n ) x[[i]] <- ( x[[i]] - xm[[i]] ) / xsd[[i]] 
+
+    # apply wavelet transform
+    dt    <- lapply( x, dualtrees::dtcwt, dec=TRUE, 
+                        fb1 = dualtrees::near_sym_b_bp, 
+                        fb2 = dualtrees::qshift_b_bp )
+
+
+    res <- list( obs0 )
+
+    # correct each forecast
+    dto <- dt[[1]]
+    for( i in 2:n ){ # loop over forecasts
+        dtf <- dt[[i]]
+        for( j in 1:J ){ # loop over all scales
+            if( direction ){ # correct each direction individually
+                for( d in 1:6 ){
+                    fac       <- sum(Mod(dto[[j]][,,d])**2) / 
+                                 sum(Mod(dtf[[j]][,,d])**2)
+                    dtf[[j]][,,d] <- dtf[[j]][,,d]*fac
+                } 
+            }else{ # correct all directions together
+                fac       <- sum(Mod(dto[[j]])**2) / 
+                                 sum(Mod(dtf[[j]])**2)
+                    dtf[[j]] <- dtf[[j]]*fac
+            }
+
+        } 
+        # transform back
+        fbc <- idtcwt( dtf, fb1 = dualtrees::near_sym_b_bp, 
+                            fb2 = dualtrees::qshift_b_bp 
+                     )
+        # restore margins
+        fbc <- ( fbc - mean(fbc) )/ stats::sd(fbc) * xsd[[i]] + xm[[i]]
+        # cut out original domain
+        fbc <- with( attributes(x), fbc[px,py] )
+        # invert logarithm (maybe)
+        if( log ) fbc <- 2**fbc - xmin
+        res[[i]] <- fbc
+    }
+
+
+    return( structure(res, class="sadforecast" ) )
+}