├── .gitattributes ├── src ├── .gitignore ├── spatiallong.cpp ├── spatialwide.cpp ├── init.c ├── pointinpoly.cpp ├── helpfunc.h ├── fillhexa.cpp ├── drawing_functions.cpp ├── posdecis.cpp ├── spitcenter.cpp └── RcppExports.cpp ├── data ├── KT_spits.rda ├── KT_vessel.rda └── KT_squarecorners.rda ├── tests ├── testthat.R └── testthat │ ├── test_spitcenter.R │ ├── test_kriglist.R │ ├── test_pnp.R │ ├── test_drawing_functions.R │ ├── test_fillhexa.R │ ├── test_posdec.R │ ├── test_spatialwidelong.R │ ├── test_spitcenternat.R │ └── test_cootrans.R ├── .Rbuildignore ├── R ├── zzz.R ├── data.R ├── geo_functions.R ├── cootrans_func.R └── RcppExports.R ├── .gitignore ├── recexcavAAR.Rproj ├── .travis.yml ├── NAMESPACE ├── man ├── KT_squarecorners.Rd ├── KT_spits.Rd ├── draw_circle.Rd ├── rescale.Rd ├── draw_sphere.Rd ├── pnpmulti.Rd ├── KT_vessel.Rd ├── spatiallong.Rd ├── fillhexa.Rd ├── spitcenter.Rd ├── pnp.Rd ├── spatialwide.Rd ├── rotate.Rd ├── posdec.Rd ├── kriglist.Rd ├── posdeclist.Rd ├── spitcenternat.Rd ├── cootrans.Rd └── spitcenternatlist.Rd ├── playground ├── plot_texture.R ├── surface_reconstruction.R └── profile │ ├── Profile_10.dat │ ├── Profile_8.dat │ ├── profile_prep.R │ ├── Profile_S.dat │ └── Profile_NW3.dat ├── NEWS.md ├── data-raw ├── prep_files.R ├── KT_squarecorners.csv └── KT_spits.csv ├── DESCRIPTION ├── cran-comments.md ├── README.md └── vignettes ├── recexcavAAR-vignette-1.Rmd ├── recexcavAAR-vignette-3.Rmd └── recexcavAAR-vignette-2.Rmd /.gitattributes: -------------------------------------------------------------------------------- 1 | R/* linguist-vendored 2 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /data/KT_spits.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ISAAKiel/recexcavAAR/HEAD/data/KT_spits.rda -------------------------------------------------------------------------------- /data/KT_vessel.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ISAAKiel/recexcavAAR/HEAD/data/KT_vessel.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(recexcavAAR) 3 | 4 | test_check("recexcavAAR") 5 | -------------------------------------------------------------------------------- /data/KT_squarecorners.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ISAAKiel/recexcavAAR/HEAD/data/KT_squarecorners.rda -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^codecov\.yml$ 5 | data-raw 6 | playground 7 | ^cran-comments\.md$ 8 | ^revdep$ 9 | ^qgis$ 10 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # General roxygen tags 2 | #' @useDynLib recexcavAAR 3 | #' @importFrom Rcpp sourceCpp 4 | #' @import stats 5 | #' @importFrom sp SpatialPointsDataFrame CRS 6 | 7 | #' @export 8 | .onUnload <- function (libpath) { 9 | library.dynam.unload("recexcavAAR", libpath) 10 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | 6 | # bytecode 7 | src/*.o 8 | src/*.so 9 | src/*.dll 10 | 11 | # produced vignettes 12 | vignettes/*.html 13 | vignettes/*.pdf 14 | vignettes/*.R 15 | inst/doc/ 16 | 17 | # downloaded example data 18 | *.jpg 19 | 20 | # reverse dependencies: devtools::revdep_check() 21 | revdep -------------------------------------------------------------------------------- /recexcavAAR.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageCheckArgs: --as-cran 21 | PackageRoxygenize: rd,collate,namespace,vignette 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | cache: packages 5 | 6 | matrix: 7 | include: 8 | - os: linux 9 | dist: trusty 10 | env: R_CODECOV=true 11 | r_check_args: '--use-valgrind' 12 | - os: osx 13 | osx_image: xcode10.1 14 | 15 | addons: 16 | apt: 17 | packages: 18 | - valgrind 19 | 20 | warnings_are_errors: true 21 | 22 | r_packages: 23 | - covr 24 | 25 | after_success: 26 | - Rscript -e 'library(covr); codecov()' -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(.onUnload) 4 | export(cootrans) 5 | export(draw_circle) 6 | export(draw_sphere) 7 | export(fillhexa) 8 | export(kriglist) 9 | export(pnp) 10 | export(pnpmulti) 11 | export(posdec) 12 | export(posdeclist) 13 | export(rescale) 14 | export(rotate) 15 | export(spatiallong) 16 | export(spatialwide) 17 | export(spitcenter) 18 | export(spitcenternat) 19 | export(spitcenternatlist) 20 | import(kriging) 21 | import(stats) 22 | importFrom(Rcpp,sourceCpp) 23 | importFrom(sp,CRS) 24 | importFrom(sp,SpatialPointsDataFrame) 25 | useDynLib(recexcavAAR) 26 | -------------------------------------------------------------------------------- /man/KT_squarecorners.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \name{KT_squarecorners} 4 | \alias{KT_squarecorners} 5 | \title{KT_data: Corner points of a 1m*1m raster within the trench of a fictional excavation KT} 6 | \format{A data frame with 63 rows and 2 variables: 7 | \itemize{ 8 | \item x: x axis coordinates of corner points 9 | \item y: y axis coordinates of corner points 10 | }} 11 | \description{ 12 | A dataset containing horizontal coordinates of corner points of a 1m*1m raster within 13 | the rectangular trench (corner points of squares). 14 | } 15 | \seealso{ 16 | Other KT_data: \code{\link{KT_spits}}, 17 | \code{\link{KT_vessel}} 18 | } 19 | \concept{KT_data} 20 | -------------------------------------------------------------------------------- /man/KT_spits.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \name{KT_spits} 4 | \alias{KT_spits} 5 | \title{KT_data: Niveau measurements from the fictional trench of a excavation KT} 6 | \format{A data frame with 304 rows and 4 variables: 7 | \itemize{ 8 | \item id: IDs of individual measurements with the information about to which level 9 | they belong 10 | \item x: x axis coordinates of measurements 11 | \item y: y axis coordinates of measurements 12 | \item z: z axis coordinates of measurements 13 | }} 14 | \description{ 15 | A dataset containing coordinates of niveau measurements of a fictional excavation KT with 16 | 4 spits. 17 | } 18 | \seealso{ 19 | Other KT_data: \code{\link{KT_squarecorners}}, 20 | \code{\link{KT_vessel}} 21 | } 22 | \concept{KT_data} 23 | -------------------------------------------------------------------------------- /tests/testthat/test_spitcenter.R: -------------------------------------------------------------------------------- 1 | context("Tests of function spitcenter") 2 | 3 | hexatestdf <- data.frame( 4 | x = c(0,1,0,4,5,5,5,5), 5 | y = c(1,1,4,4,1,1,4,4), 6 | z = c(4,8,4,9,4,8,4,6) 7 | ) 8 | 9 | center <- spitcenter(hexatestdf) 10 | 11 | test_that( 12 | "the output is a vector", { 13 | expect_true( 14 | is.vector(center) 15 | ) 16 | } 17 | ) 18 | 19 | test_that( 20 | "the output has the correct length and names", { 21 | expect_equal( 22 | length(center), 23 | 3 24 | ) 25 | expect_equal( 26 | names(center), 27 | c("x", "y", "z") 28 | ) 29 | } 30 | ) 31 | 32 | countercenter <- c(x = 3.125, y = 2.5, z = 5.875) 33 | 34 | test_that( 35 | "the output is as expected", { 36 | expect_identical( 37 | center, 38 | countercenter 39 | ) 40 | } 41 | ) 42 | -------------------------------------------------------------------------------- /tests/testthat/test_kriglist.R: -------------------------------------------------------------------------------- 1 | context("Tests of function kriglist") 2 | 3 | df1 <- data.frame( 4 | x = rnorm(50), 5 | y = rnorm(50), 6 | z = rnorm(50) - 5 7 | ) 8 | 9 | df2 <- data.frame( 10 | x = rnorm(50), 11 | y = rnorm(50), 12 | z = rnorm(50) + 5 13 | ) 14 | 15 | lpoints <- list(df1, df2) 16 | 17 | res <- kriglist(lpoints, lags = 3, model = "spherical") 18 | 19 | test_that( 20 | "the output of spatialwide is a list of data.frames", { 21 | expect_true( 22 | is.list(res) 23 | ) 24 | expect_true( 25 | is.data.frame(res[[1]]) 26 | ) 27 | expect_true( 28 | is.data.frame(res[[2]]) 29 | ) 30 | } 31 | ) 32 | 33 | test_that( 34 | "the output data.frames of spatialwide have the correct colnames", { 35 | expect_equal( 36 | colnames(res[[1]]), 37 | c("x", "y", "pred") 38 | ) 39 | expect_equal( 40 | colnames(res[[2]]), 41 | c("x", "y", "pred") 42 | ) 43 | } 44 | ) -------------------------------------------------------------------------------- /playground/plot_texture.R: -------------------------------------------------------------------------------- 1 | library(rgl) 2 | library(jpeg) 3 | 4 | # download and load picture 5 | download.file( 6 | url = 'https://upload.wikimedia.org/wikipedia/en/6/6d/Chewbacca-2-.jpg', 7 | destfile = "chewbacca.jpg", 8 | mode = 'wb' 9 | ) 10 | 11 | chewie <- readJPEG("chewbacca.jpg", native = TRUE) 12 | 13 | # create some sample data 14 | x <- sort(rnorm(1000)) 15 | y <- rnorm(1000) 16 | z <- rnorm(1000) + atan2(x, y) 17 | 18 | # plot sample data 19 | plot3d(x, y, z, col = rainbow(1000), size = 5) 20 | 21 | # add picture 22 | show2d( 23 | # plot raster 24 | { 25 | par(mar = rep(0, 4)) 26 | plot( 27 | 0:1, 0:1, type="n", 28 | ann = FALSE, axes = FALSE, 29 | xaxs = "i", yaxs = "i" 30 | ) 31 | rasterImage(chewie, 0, 0, 1, 1) 32 | }, 33 | # image position and extent 34 | # coordinate order: lower left, lower right, upper right and upper left 35 | x = c(-2, 1, 1, -2), 36 | y = c(-1, -1, 1, 1), 37 | z = c(-3, -3, 2, 2) 38 | ) -------------------------------------------------------------------------------- /man/draw_circle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{draw_circle} 4 | \alias{draw_circle} 5 | \title{Draws a circular point cloud (3D)} 6 | \usage{ 7 | draw_circle(centerx, centery, centerz, radius, resolution = 30L) 8 | } 9 | \arguments{ 10 | \item{centerx}{x axis value of circle center point} 11 | 12 | \item{centery}{y axis value of circle center point} 13 | 14 | \item{centerz}{z axis value of circle center point} 15 | 16 | \item{radius}{circle radius} 17 | 18 | \item{resolution}{amount of circle points (default = 30)} 19 | } 20 | \value{ 21 | data.frame with the spatial coordinates of the resulting points 22 | } 23 | \description{ 24 | Draws a 2D circle on x- and y-plane around a center point in 3D space. 25 | } 26 | \examples{ 27 | draw_circle( 28 | centerx = 4, 29 | centery = 5, 30 | centerz = 1, 31 | radius = 3, 32 | resolution = 20 33 | ) 34 | 35 | circ <- draw_circle(1,2,3,2) 36 | 37 | plot(circ$x, circ$y) 38 | 39 | } 40 | -------------------------------------------------------------------------------- /man/rescale.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{rescale} 4 | \alias{rescale} 5 | \title{Scales a point cloud (3D)} 6 | \usage{ 7 | rescale(x, y, z, scalex = 1, scaley = 1, scalez = 1) 8 | } 9 | \arguments{ 10 | \item{x}{vector of x axis values of scale point cloud} 11 | 12 | \item{y}{vector of y axis values of scale point cloud} 13 | 14 | \item{z}{vector of z axis values of scale point cloud} 15 | 16 | \item{scalex}{scaling factor on x axis (default = 1)} 17 | 18 | \item{scaley}{scaling factor on y axis (default = 1)} 19 | 20 | \item{scalez}{scaling factor on z axis (default = 1)} 21 | } 22 | \value{ 23 | data.frame with the spatial coordinates of the resulting points 24 | } 25 | \description{ 26 | Scales a 3D point cloud on every axis. 27 | } 28 | \examples{ 29 | s <- draw_sphere(1,1,1,3) 30 | 31 | #library(rgl) 32 | #plot3d(s) 33 | 34 | s2 <- rescale(s$x, s$y, s$z, scalex = 4, scalez = 5) 35 | 36 | #library(rgl) 37 | #plot3d(s2) 38 | 39 | } 40 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | recexcavAAR 0.3.0 2 | ---------------------------------------------------------------- 3 | 4 | * added coordinate transformation function and related vignette 5 | 6 | * improved vignettes 7 | 8 | * added some basic 3D drawing functions 9 | 10 | recexcavAAR 0.2.2 11 | ---------------------------------------------------------------- 12 | 13 | * bugfixes as a reaction to CRAN checks 14 | 15 | * replaced plotly with rgl in the vignettes 16 | 17 | recexcavAAR 0.2.1 18 | ---------------------------------------------------------------- 19 | 20 | * preparations for CRAN release 21 | 22 | recexcavAAR 0.2.0 23 | ---------------------------------------------------------------- 24 | 25 | * creation of some functions for the analysis of Kakcus-Turjan - see vignette 26 | 27 | * reorganisation of previous functions (renaming, translation into Rcpp) 28 | 29 | recexcavAAR 0.1.0 30 | ---------------------------------------------------------------- 31 | 32 | * creation of some functions for the analysis of Ifri el Baroud - see vignette -------------------------------------------------------------------------------- /data-raw/prep_files.R: -------------------------------------------------------------------------------- 1 | library(devtools) 2 | 3 | #### KT tables #### 4 | KT_squarecorners <- read.csv("data-raw/KT_squarecorners.csv", sep = ";") 5 | KT_spits <- read.csv("data-raw/KT_spits.csv", sep = ";") 6 | 7 | devtools::use_data(KT_squarecorners, KT_spits, overwrite = TRUE) 8 | 9 | #### KT small datasets #### 10 | vesselsingle <- data.frame( 11 | inv = c("KTF_123", "KTF_167", "KTF_179"), 12 | spit = c("spit1", "spit1", "spit2"), 13 | square = c(20, 20, 13), 14 | feature = c(3, 3, 5), 15 | x = c(5.493, 5.349, 6.006), 16 | y = c(15.061, 15.075, 16.677), 17 | z = c(9.556, 9.611, 9.253), 18 | stringsAsFactors = FALSE 19 | ) 20 | 21 | vesselmass <- data.frame( 22 | inv = c("KTM_45", "KTM_56", "KTM_77", "KTM_98"), 23 | spit = c("spit2", "bottom", "spit1", "bottom"), 24 | square = c(20, 35, 47, 25), 25 | feature = c(5, 5, 7, 3), 26 | x = NaN, 27 | y = NaN, 28 | z = NaN, 29 | stringsAsFactors = FALSE 30 | ) 31 | 32 | KT_vessel <- rbind(vesselsingle, vesselmass) 33 | 34 | devtools::use_data(KT_vessel, overwrite = TRUE) 35 | -------------------------------------------------------------------------------- /man/draw_sphere.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{draw_sphere} 4 | \alias{draw_sphere} 5 | \title{Draws a spherical point cloud (3D)} 6 | \usage{ 7 | draw_sphere(centerx, centery, centerz, radius, phires = 10L, 8 | thetares = 10L) 9 | } 10 | \arguments{ 11 | \item{centerx}{x axis value of sphere center point} 12 | 13 | \item{centery}{y axis value of sphere center point} 14 | 15 | \item{centerz}{z axis value of sphere center point} 16 | 17 | \item{radius}{sphere radius} 18 | 19 | \item{phires}{phi resolution (default = 10)} 20 | 21 | \item{thetares}{theta resolution (default = 10)} 22 | } 23 | \value{ 24 | data.frame with the spatial coordinates of the resulting points 25 | } 26 | \description{ 27 | Draws a sphere around a center point in 3D space. 28 | } 29 | \examples{ 30 | sphere <- draw_sphere( 31 | centerx = 4, 32 | centery = 5, 33 | centerz = 1, 34 | radius = 3, 35 | phires = 20, 36 | thetares = 20 37 | ) 38 | 39 | #library(rgl) 40 | #plot3d(sphere) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /data-raw/KT_squarecorners.csv: -------------------------------------------------------------------------------- 1 | x;y 2 | 0.669;14.273 3 | 1.449;14.898 4 | 2.23;15.524 5 | 3.01;16.149 6 | 3.79;16.775 7 | 4.57;17.4 8 | 5.35;18.026 9 | 6.131;18.651 10 | 6.899;19.292 11 | 1.296;13.494 12 | 2.076;14.119 13 | 2.856;14.744 14 | 3.636;15.37 15 | 4.417;15.995 16 | 5.197;16.621 17 | 5.977;17.246 18 | 6.757;17.872 19 | 7.526;18.512 20 | 1.922;12.714 21 | 2.702;13.34 22 | 3.483;13.965 23 | 4.263;14.591 24 | 5.043;15.216 25 | 5.823;15.842 26 | 6.604;16.467 27 | 7.384;17.092 28 | 8.152;17.733 29 | 2.549;11.935 30 | 3.329;12.56 31 | 4.109;13.186 32 | 4.889;13.811 33 | 5.67;14.437 34 | 6.45;15.062 35 | 7.23;15.688 36 | 8.01;16.313 37 | 8.779;16.954 38 | 3.175;11.155 39 | 3.955;11.781 40 | 4.736;12.406 41 | 5.516;13.032 42 | 6.296;13.657 43 | 7.076;14.283 44 | 7.857;14.908 45 | 8.637;15.534 46 | 9.405;16.174 47 | 3.802;10.376 48 | 4.582;11.001 49 | 5.362;11.627 50 | 6.142;12.252 51 | 6.923;12.878 52 | 7.703;13.503 53 | 8.483;14.129 54 | 9.264;14.754 55 | 10.032;15.395 56 | 4.428;9.597 57 | 5.209;10.222 58 | 5.989;10.848 59 | 6.769;11.473 60 | 7.549;12.099 61 | 8.33;12.724 62 | 9.11;13.35 63 | 9.89;13.975 64 | 10.658;14.615 65 | -------------------------------------------------------------------------------- /man/pnpmulti.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{pnpmulti} 4 | \alias{pnpmulti} 5 | \title{Check if multiple points are within a polygon (2D)} 6 | \usage{ 7 | pnpmulti(vertx, verty, testx, testy) 8 | } 9 | \arguments{ 10 | \item{vertx}{vector of x axis values of polygon corner points} 11 | 12 | \item{verty}{vector of y axis values of polygon corner points} 13 | 14 | \item{testx}{vector of x axis values of points of interest} 15 | 16 | \item{testy}{vector of y axis values of points of interest} 17 | } 18 | \value{ 19 | vector with boolean values - TRUE, if the respective point is within the polygon. 20 | Otherwise FALSE. 21 | } 22 | \description{ 23 | \code{pnpmulti} works as \code{\link{pnp}} but for multiple points. 24 | } 25 | \examples{ 26 | polydf <- data.frame( 27 | x = c(1,1,2,2), 28 | y = c(1,2,1,2) 29 | ) 30 | 31 | testdf <- data.frame( 32 | x = c(1.5, 2.5), 33 | y = c(1.5, 2.5) 34 | ) 35 | 36 | pnpmulti(polydf$x, polydf$y, testdf$x, testdf$y) 37 | 38 | } 39 | \seealso{ 40 | Other pnpfuncs: \code{\link{pnp}} 41 | } 42 | \concept{pnpfuncs} 43 | -------------------------------------------------------------------------------- /man/KT_vessel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \name{KT_vessel} 4 | \alias{KT_vessel} 5 | \title{KT_data: Information about individual sherds of a reconstructed vessel from the trench 6 | of a fictional excavation KT} 7 | \format{A data frame with 7 rows and 7 variables: 8 | \itemize{ 9 | \item inv: Inventory numbers of sherds. KTF means single find with individual measurement, 10 | KTM means mass find without this precise information. 11 | \item spit: spits where the sherds were found 12 | \item square: squares where the sherds were found 13 | \item feature: features where the sherds were found 14 | \item x: x axis coordinates of sherds 15 | \item y: y axis coordinates of sherds 16 | \item z: z axis coordinates of sherds 17 | }} 18 | \description{ 19 | A dataset containing spatial and contextual information for individual sherds of a single 20 | vessel. Some sherds were documented in the field with single find measurements. For the 21 | others only spit and square attribution is possible. 22 | } 23 | \seealso{ 24 | Other KT_data: \code{\link{KT_spits}}, 25 | \code{\link{KT_squarecorners}} 26 | } 27 | \concept{KT_data} 28 | -------------------------------------------------------------------------------- /man/spatiallong.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spatiallong} 4 | \alias{spatiallong} 5 | \title{Transformation of numeric matrices from wide to long format} 6 | \usage{ 7 | spatiallong(x, y, z) 8 | } 9 | \arguments{ 10 | \item{x}{vector of first independent variable. e.g. vector with x axis spatial points} 11 | 12 | \item{y}{vector of second independent variable. e.g. vector with y axis spatial points} 13 | 14 | \item{z}{matrix of dependent variable. e.g. matrix with z axis spatial points} 15 | } 16 | \value{ 17 | data.frame with three columns x, y and z 18 | } 19 | \description{ 20 | \code{spatiallong} transforms a set of two independent variables in vectors and a 21 | dependent variable in a wide matrix to a long matrix that combines the information. 22 | The result is exported as a data.frame. 23 | } 24 | \examples{ 25 | x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 26 | y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 27 | z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 28 | 29 | sw <- spatialwide(x, y, z, digits = 3) 30 | 31 | spatiallong(sw$x, sw$y, sw$z) 32 | 33 | } 34 | \seealso{ 35 | Other transfuncs: \code{\link{spatialwide}} 36 | } 37 | \concept{transfuncs} 38 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: recexcavAAR 2 | Type: Package 3 | Title: 3D Reconstruction of Archaeological Excavations 4 | Version: 0.3.0.9000 5 | Authors@R: c( 6 | person("Clemens", "Schmid", email = "clemens@nevrome.de", role = c("cre", "cph", "aut")), 7 | person("Benjamin", "Serbe", email = "b.serbe@web.de", role = c("aut")) 8 | ) 9 | Maintainer: Clemens Schmid 10 | Description: A toolset for 3D reconstruction and analysis of excavations. It provides methods to reconstruct natural and artificial surfaces based on field measurements. This allows to spatially contextualize documented subunits and features. Intended to be part of a 3D visualization workflow. 11 | Date: 2017-02-15 12 | License: GPL-2 13 | LazyData: TRUE 14 | RoxygenNote: 6.1.1 15 | URL: https://github.com/ISAAKiel/recexcavAAR 16 | Imports: 17 | Rcpp (>= 0.12.7), 18 | sp (>= 1.2) 19 | Suggests: 20 | devtools (>= 1.12.0), 21 | dplyr (>= 0.5.0), 22 | knitr (>= 1.15.1), 23 | magrittr (>= 1.5), 24 | rgl (>= 0.96.0), 25 | rmarkdown (>= 1.0), 26 | roxygen2 (>= 5.0.1), 27 | testthat (>= 1.0.2) 28 | VignetteBuilder: knitr 29 | Depends: 30 | R (>= 3.3.0), 31 | kriging (>= 1.1) 32 | LinkingTo: Rcpp 33 | Encoding: UTF-8 34 | -------------------------------------------------------------------------------- /tests/testthat/test_pnp.R: -------------------------------------------------------------------------------- 1 | context("Tests of functions pnp and pnpmulti") 2 | 3 | polydf <- data.frame( 4 | x = c(1,1,2,2), 5 | y = c(1,2,1,2) 6 | ) 7 | 8 | pisin <- pnp(polydf$x, polydf$y, 1.5, 1.5) 9 | pisout <- pnp(polydf$x, polydf$y, 2.5, 2.5) 10 | 11 | testdf <- data.frame( 12 | x = c(1.5, 2.5), 13 | y = c(1.5, 2.5) 14 | ) 15 | 16 | multi <- pnpmulti(polydf$x, polydf$y, testdf$x, testdf$y) 17 | 18 | test_that( 19 | "the output of pnp is a boolean value", { 20 | expect_true( 21 | is.logical(pisin) 22 | ) 23 | expect_true( 24 | is.logical(pisout) 25 | ) 26 | } 27 | ) 28 | 29 | test_that( 30 | "the output of pnpmulti is a boolean vector", { 31 | expect_true( 32 | is.logical(multi) 33 | ) 34 | } 35 | ) 36 | 37 | test_that( 38 | "the output of pnpmuti has the correct amout of values", { 39 | expect_equal( 40 | length(multi), 41 | nrow(testdf) 42 | ) 43 | } 44 | ) 45 | 46 | test_that( 47 | "the output of pnp is as expected", { 48 | expect_true( 49 | pisin 50 | ) 51 | expect_false( 52 | pisout 53 | ) 54 | } 55 | ) 56 | 57 | test_that( 58 | "the output of pnpmulti is as expected", { 59 | expect_identical( 60 | multi, 61 | c(TRUE, FALSE) 62 | ) 63 | } 64 | ) -------------------------------------------------------------------------------- /man/fillhexa.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{fillhexa} 4 | \alias{fillhexa} 5 | \title{Fills hexahedrons with a regular point raster (3D)} 6 | \usage{ 7 | fillhexa(hex, res) 8 | } 9 | \arguments{ 10 | \item{hex}{dataframe with three columns and eight rows to define a hexahedron by its corner 11 | point coordinates x, y and z} 12 | 13 | \item{res}{numeric value > 0 and <= 1 for the resolution of the point raster} 14 | } 15 | \value{ 16 | data.frame with the spatial coordinates of the resulting points of the grid 17 | } 18 | \description{ 19 | A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 20 | \code{fillhexa} allows to fill such a shape with a regular point raster. 21 | } 22 | \details{ 23 | See \url{https://stackoverflow.com/questions/36115215/filling-a-3d-body-with-a-systematic-point-raster} 24 | for a description of the function and how it was developed. 25 | } 26 | \examples{ 27 | hexatestdf <- data.frame( 28 | x = c(0,1,0,4,5,5,5,5), 29 | y = c(1,1,4,4,1,1,4,4), 30 | z = c(4,8,4,9,4,8,4,6) 31 | ) 32 | 33 | cx = fillhexa(hexatestdf, 0.1) 34 | 35 | #library(rgl) 36 | #plot3d( 37 | # cx[,1], cx[,2], cx[,3], 38 | # type = "p", 39 | # xlab = "x", ylab = "y", zlab = "z" 40 | #) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /man/spitcenter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spitcenter} 4 | \alias{spitcenter} 5 | \title{Center determination for hexahedrons} 6 | \usage{ 7 | spitcenter(hex) 8 | } 9 | \arguments{ 10 | \item{hex}{dataframe with three columns and eight rows to define a hexahedron by its corner 11 | point coordinates x, y and z} 12 | } 13 | \value{ 14 | vector with the spatial coordinates of the center point of the input hexahedron 15 | } 16 | \description{ 17 | A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 18 | \code{spitcenter} determines a center point for an input hexahedron by calculating the mean 19 | of the maximal extent on all three axis. 20 | } 21 | \examples{ 22 | hexatestdf <- data.frame( 23 | x = c(0,1,0,4,5,5,5,5), 24 | y = c(1,1,4,4,1,1,4,4), 25 | z = c(4,8,4,9,4,8,4,6) 26 | ) 27 | 28 | center <- spitcenter(hexatestdf) 29 | 30 | #library(rgl) 31 | #plot3d( 32 | # hexatestdf$x, hexatestdf$y, hexatestdf$z, 33 | # type = "p", 34 | # xlab = "x", ylab = "y", zlab = "z" 35 | #) 36 | #plot3d( 37 | # center[1], center[2], center[3], 38 | # type = "p", 39 | # col = "red", 40 | # add = TRUE 41 | #) 42 | 43 | } 44 | \seealso{ 45 | Other centerdetfuncs: \code{\link{spitcenternatlist}}, 46 | \code{\link{spitcenternat}} 47 | } 48 | \concept{centerdetfuncs} 49 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Resubmission 2 | This is a resubmission. In this version I have: 3 | 4 | * added a init.c file to register the c++-functions 5 | 6 | ## Improvements for new submission 7 | 8 | * new functions (coordinate transformation and 3D drawing) 9 | * improved vignettes 10 | 11 | ## Test environments 12 | * Manjaro Linux 64-bit, R 3.3.2 13 | * win-builder (release+devel) 14 | * Rhub: 15 | Debian Linux, R-devel, GCC ASAN/UBSAN 16 | Ubuntu Linux 16.04 LTS, R-release, GCC 17 | Fedora Linux, R-devel, clang, gfortran 18 | 19 | ### Travis CI matrix: 20 | 21 | * os: linux 22 | * dist: precise 23 | * sudo: false 24 | * os: linux 25 | * dist: trusty 26 | * sudo: required 27 | * env: R_CODECOV=true 28 | * r_check_args: '--use-valgrind' 29 | * os: osx 30 | * osx_image: xcode8.2 31 | * os: osx 32 | * osx_image: xcode7.3 33 | 34 | ## R CMD check results in my test environments 35 | 36 | There were no ERRORs or WARNINGs. I see two NOTEs: 37 | 38 | * Possibly mis-spelled words in DESCRIPTION: 39 | subunits (9:221) 40 | toolset (9:16) 41 | workflow (9:286) 42 | * Examples with CPU or elapsed time > 5s 43 | user system elapsed 44 | posdeclist 13.968 0.028 14.028 45 | 46 | I think both NOTEs are negligible, because they don't interfere with the functionality of the package in any way. -------------------------------------------------------------------------------- /man/pnp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{pnp} 4 | \alias{pnp} 5 | \title{Check if a point is within a polygon (2D)} 6 | \usage{ 7 | pnp(vertx, verty, testx, testy) 8 | } 9 | \arguments{ 10 | \item{vertx}{vector of x axis values of polygon corner points} 11 | 12 | \item{verty}{vector of y axis values of polygon corner points} 13 | 14 | \item{testx}{x axis value of point of interest} 15 | 16 | \item{testy}{y axis value of point of interest} 17 | } 18 | \value{ 19 | boolean value - TRUE, if the point is within the polygon. Otherwise FALSE. 20 | } 21 | \description{ 22 | \code{pnp} is able to determine if a point is within a polygon in 2D space. 23 | The polygon is described by its corner points. The points must be in a correct 24 | drawing order. 25 | 26 | Based on this solution: 27 | Copyright (c) 1970-2003, Wm. Randolph Franklin 28 | \url{http://wrf.ecse.rpi.edu/pmwiki/pmwiki.php/Main/Software#toc24} 29 | } 30 | \details{ 31 | For discussion see: \url{http://stackoverflow.com/questions/217578/how-can-i-determine-whether-a-2d-point-is-within-a-polygon/2922778#2922778} 32 | } 33 | \examples{ 34 | df <- data.frame( 35 | x = c(1,1,2,2), 36 | y = c(1,2,1,2) 37 | ) 38 | 39 | pnp(df$x, df$y, 1.5, 1.5) 40 | pnp(df$x, df$y, 2.5, 2.5) 41 | 42 | # caution: false-negatives in edge-cases: 43 | pnp(df$x, df$y, 2, 1.5) 44 | 45 | } 46 | \seealso{ 47 | Other pnpfuncs: \code{\link{pnpmulti}} 48 | } 49 | \concept{pnpfuncs} 50 | -------------------------------------------------------------------------------- /tests/testthat/test_drawing_functions.R: -------------------------------------------------------------------------------- 1 | context("Tests of drawing functions") 2 | 3 | circle <- draw_circle( 4 | centerx = 0, centery = 0, centerz = 0, 5 | radius = 25, resolution = 200 6 | ) 7 | 8 | rotatedcircle <- rotate( 9 | x = circle$x, y = circle$y, z = circle$z, 10 | degrx = 45 11 | ) 12 | 13 | # library(rgl) 14 | # plot3d(rotatedcircle) 15 | 16 | sphere <- draw_sphere( 17 | centerx = 0, centery = 0, centerz = 0, 18 | radius = 2, phires = 20, thetares = 20 19 | ) 20 | 21 | scaledsphere <- rescale( 22 | sphere$x, sphere$y, sphere$z, 23 | scalex = 10, scaley = 10, scalez = 10 24 | ) 25 | 26 | # plot3d(scaledsphere, add = TRUE) 27 | 28 | test_that( 29 | "the output of all the drawing functions are data.frames", { 30 | expect_true( 31 | all( 32 | is.data.frame(circle), 33 | is.data.frame(rotatedcircle), 34 | is.data.frame(sphere), 35 | is.data.frame(scaledsphere) 36 | ) 37 | ) 38 | } 39 | ) 40 | 41 | test_that( 42 | "the output data.frames of all the drawing functions 43 | have the correct colnames and amount of columns", { 44 | expect_equal( 45 | colnames(circle), 46 | c("x", "y", "z") 47 | ) 48 | expect_equal( 49 | colnames(rotatedcircle), 50 | c("x", "y", "z") 51 | ) 52 | expect_equal( 53 | colnames(sphere), 54 | c("x", "y", "z") 55 | ) 56 | expect_equal( 57 | colnames(scaledsphere), 58 | c("x", "y", "z") 59 | ) 60 | } 61 | ) -------------------------------------------------------------------------------- /man/spatialwide.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spatialwide} 4 | \alias{spatialwide} 5 | \title{Transformation of numeric matrices from long to wide format} 6 | \usage{ 7 | spatialwide(x, y, z, digits) 8 | } 9 | \arguments{ 10 | \item{x}{vector of first independent variable. e.g. vector with x-axis spatial points} 11 | 12 | \item{y}{vector of second independent variable. e.g. vector with y-axis spatial points} 13 | 14 | \item{z}{vector of dependent variable. e.g. vector with z-axis spatial points} 15 | 16 | \item{digits}{integer indicating the number of decimal places to be used for rounding 17 | the dependent variables \code{x} and \code{y}.} 18 | } 19 | \value{ 20 | List with three elements: 21 | 22 | $x: vector with ascendingly sorted, unique values of the first independent variable \code{x} 23 | 24 | $y: vector with ascendingly sorted, unique values of the second independent variable \code{y} 25 | 26 | $z: matrix with the values of z for the defined combinations of \code{x} (columns) and 27 | \code{y} (rows) 28 | } 29 | \description{ 30 | Transforms a set of two independent and one dependent variables in vectors from a long 31 | to a wide format and exports this result as a list 32 | } 33 | \examples{ 34 | x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 35 | y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 36 | z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 37 | 38 | spatialwide(x, y, z, digits = 3) 39 | 40 | } 41 | \seealso{ 42 | Other transfuncs: \code{\link{spatiallong}} 43 | } 44 | \concept{transfuncs} 45 | -------------------------------------------------------------------------------- /playground/surface_reconstruction.R: -------------------------------------------------------------------------------- 1 | library(plotly) 2 | 3 | #### preparations #### 4 | edges <- data.frame( 5 | x = c(0, 3, 0, 3, 0, 3, 0, 3), 6 | y = c(0, 0, 0, 0, 1, 1, 1, 1), 7 | z = c(0, 0, 2, 2, 0, 0, 2, 2) 8 | ) 9 | 10 | vis <- plot_ly(edges, x = x, y = y, z = z, type = "scatter3d", mode = "markers" 11 | ) %>% 12 | layout( 13 | showlegend = FALSE, 14 | autorange = F, 15 | aspectmode = 'manual', 16 | scene = list( 17 | dragmode = "orbit", 18 | aspectratio = list(x=3, y=1, z=3), 19 | camera = list( 20 | eye = list(x = 4, y = 4, z = 1) 21 | ) 22 | ) 23 | ) 24 | 25 | df1 <- data.frame( 26 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 27 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 28 | z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 29 | ) 30 | 31 | vis <- vis %>% 32 | add_trace(data = df1, x = x, y = y, z = z, 33 | mode = "markers", type = "scatter3d", 34 | marker = list(size = 4, color = "red", symbol = 104) 35 | ) 36 | 37 | a <- list(x = df1$x, y = df1$y, z = df1$z) 38 | 39 | #### akima #### 40 | library(akima) 41 | akima.li <- interp(df1$x, df1$y, df1$z) 42 | # plot(a, pch = 3) 43 | # image (akima.li, add=TRUE) 44 | # contour(akima.li, add=TRUE) 45 | vis %>% add_trace( 46 | x = akima.li$x, 47 | y = akima.li$y, 48 | z = akima.li$z, 49 | type = "surface", 50 | showscale = FALSE 51 | ) 52 | 53 | #### geometry #### 54 | library(alphashape3d) 55 | ashape3d.obj <- ashape3d(as.matrix(df1), alpha = 0.7) 56 | plot(ashape3d.obj) 57 | # ok - this is something completly different. But it could be incredibly useful... -------------------------------------------------------------------------------- /man/rotate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{rotate} 4 | \alias{rotate} 5 | \title{Rotate a point cloud around a pivot point (3D)} 6 | \usage{ 7 | rotate(x, y, z, degrx = 0, degry = 0, degrz = 0, pivotx = NA_real_, 8 | pivoty = NA_real_, pivotz = NA_real_) 9 | } 10 | \arguments{ 11 | \item{x}{vector of x axis values of rotation point cloud} 12 | 13 | \item{y}{vector of y axis values of rotation point cloud} 14 | 15 | \item{z}{vector of z axis values of rotation point cloud} 16 | 17 | \item{degrx}{rotation angle around x axis in degree (default = 0)} 18 | 19 | \item{degry}{rotation angle around y axis in degree (default = 0)} 20 | 21 | \item{degrz}{rotation angle around z axis in degree (default = 0)} 22 | 23 | \item{pivotx}{x axis value of pivot point (default = mean(x))} 24 | 25 | \item{pivoty}{y axis value of pivot point (default = mean(y))} 26 | 27 | \item{pivotz}{z axis value of pivot point (default = mean(z))} 28 | } 29 | \value{ 30 | data.frame with the spatial coordinates of the resulting points 31 | } 32 | \description{ 33 | Rotate a point cloud around a defined pivot point by defined angles. The default 34 | rotation angle around each axis is zero and the default pivot point is the center 35 | point of the point cloud (defined by mean()) 36 | } 37 | \examples{ 38 | circ <- draw_circle(0,0,0,5) 39 | 40 | #library(rgl) 41 | #plot3d( 42 | # circ, 43 | # xlim = c(-6,6), 44 | # ylim = c(-6,6), 45 | # zlim = c(-6,6) 46 | #) 47 | 48 | rotcirc <- rotate(circ$x, circ$y, circ$z, degrx = 45) 49 | 50 | #plot3d( 51 | # rotcirc, 52 | # xlim = c(-6,6), 53 | # ylim = c(-6,6), 54 | # zlim = c(-6,6) 55 | #) 56 | 57 | } 58 | -------------------------------------------------------------------------------- /man/posdec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{posdec} 4 | \alias{posdec} 5 | \title{Multiple point position decision in relation to a set of stacked surfaces (3D)} 6 | \usage{ 7 | posdec(crdf, maplist) 8 | } 9 | \arguments{ 10 | \item{crdf}{data.frame with the spatial coordinates of the points of interest. Must contain three 11 | columns with the x axis values, y axis values and z axis values of the points in the order x, y, z} 12 | 13 | \item{maplist}{list of data.frames which contain the points that make up the surfaces. The individual 14 | data.frames must have the same structure as \code{crdf}} 15 | } 16 | \value{ 17 | data.frame with the spatial coordinates of the points of interest and the respective position 18 | information 19 | } 20 | \description{ 21 | \code{posdec} has the purpose to make a decision about the position of individual points in relation 22 | to a set of stacked surfaces in 3D space. The decision is made by comparing the mean z axis value of 23 | the four horizontally closest points of a surface to the z axis value of the point in question. 24 | } 25 | \examples{ 26 | df1 <- data.frame( 27 | x = rnorm(50), 28 | y = rnorm(50), 29 | z = rnorm(50) - 5 30 | ) 31 | 32 | df2 <- data.frame( 33 | x = rnorm(50), 34 | y = rnorm(50), 35 | z = rnorm(50) + 5 36 | ) 37 | 38 | lpoints <- list(df1, df2) 39 | 40 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 41 | 42 | finds <- data.frame( 43 | x = c(0, 1, 0.5, 0.7), 44 | y = c(0.5, 0, 1, 0.7), 45 | z = c(-10, 10, 0, 2) 46 | ) 47 | 48 | posdec(finds, maps) 49 | 50 | } 51 | \seealso{ 52 | Other posdecfuncs: \code{\link{posdeclist}} 53 | } 54 | \concept{posdecfuncs} 55 | -------------------------------------------------------------------------------- /tests/testthat/test_fillhexa.R: -------------------------------------------------------------------------------- 1 | context("Tests of function fillhexa") 2 | 3 | hex <- data.frame( 4 | x = c(0,1,0,4,5,5,5,5), 5 | y = c(1,1,4,4,1,1,4,4), 6 | z = c(4,8,4,9,4,8,4,6) 7 | ) 8 | 9 | res <- fillhexa(hex, 0.1) 10 | 11 | test_that( 12 | "the output is a data.frame", { 13 | expect_true( 14 | is.data.frame(res) 15 | ) 16 | } 17 | ) 18 | 19 | test_that( 20 | "the output has the correct amount of columns and colnames", { 21 | expect_equal( 22 | ncol(res), 23 | 3 24 | ) 25 | expect_equal( 26 | colnames(res), 27 | c("x", "y", "z") 28 | ) 29 | } 30 | ) 31 | 32 | test_that( 33 | "the output contains just points within or close to the shape (indistinct test...)", { 34 | 35 | # Idea: test if the distance between every point of a sample of 36 | # points from res and every corner point of the initial hexahedron 37 | # is bigger then the maximal corner point distances. 38 | # If so, then the tested points of res are wrongly placed. 39 | 40 | # determine size of sample (10% of res) 41 | samp <- round(nrow(res)/10, 0) 42 | 43 | # get sample and add it to hex 44 | hex2 <- rbind(hex, res[sample(nrow(res), samp), ]) 45 | 46 | # calculate dist matrix (distance between all points among themselves) 47 | d2 <- as.matrix(dist(hex2)) 48 | 49 | # determine if point distances are within or at least close to the 50 | # corner point limits 51 | # result is a boolean vector with info for every corner point 52 | # if one is false, then something is wrong 53 | t <- c() 54 | for (i in 1:8) { 55 | t[i] <- max(d2[1:8,i]) >= max(d2[i,9:(8+samp)]) 56 | } 57 | 58 | expect_true( 59 | all(t) 60 | ) 61 | 62 | } 63 | ) -------------------------------------------------------------------------------- /man/kriglist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/geo_functions.R 3 | \name{kriglist} 4 | \alias{kriglist} 5 | \title{Apply kriging \{kriging\} to a list of data.frames} 6 | \usage{ 7 | kriglist(plist, x = 1, y = 2, z = 3, rdup = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{plist}{List of data.frames with point coordinates} 11 | 12 | \item{x}{index of data.frame column with x-axis spatial points. Defaults to 1} 13 | 14 | \item{y}{index of data.frame column with y-axis spatial points. Defaults to 2} 15 | 16 | \item{z}{index of data.frame column with z-axis spatial points. Defaults to 3} 17 | 18 | \item{rdup}{switch to activate removal of double values for single horizontal positions in the input 19 | data.frames. Defaults to TRUE} 20 | 21 | \item{...}{Arguments to be passed to method \code{kriging} \{kriging\}} 22 | } 23 | \value{ 24 | list with data.frames which contains the predicted values along with the coordinate covariates 25 | } 26 | \description{ 27 | \code{kriging} \{kriging\} is a simple and highly optimized ordinary kriging algorithm to plot 28 | geographical data. This interface to the method allows to not just apply it to one data.frame but 29 | to a list of data.frames. The result is reduced to the data.frame with the predicted values. 30 | For a more detailed output \code{kriging} \{kriging\} has to be called for the individual input 31 | data.frames. 32 | } 33 | \examples{ 34 | df1 <- data.frame( 35 | x = rnorm(50), 36 | y = rnorm(50), 37 | z = rnorm(50) - 5 38 | ) 39 | 40 | df2 <- data.frame( 41 | x = rnorm(50), 42 | y = rnorm(50), 43 | z = rnorm(50) + 5 44 | ) 45 | 46 | lpoints <- list(df1, df2) 47 | 48 | surfacelist <- kriglist(lpoints, lags = 3, model = "spherical") 49 | 50 | } 51 | -------------------------------------------------------------------------------- /man/posdeclist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{posdeclist} 4 | \alias{posdeclist} 5 | \title{Multiple point position decision in relation to a set of stacked surfaces (3D) 6 | for multiple data.frames in a list} 7 | \usage{ 8 | posdeclist(crdflist, maplist) 9 | } 10 | \arguments{ 11 | \item{crdflist}{list of data.frames with the spatial coordinates of the points of 12 | interest (for details see \code{\link{posdec}})} 13 | 14 | \item{maplist}{list of data.frames which contain the points that make up the surfaces} 15 | } 16 | \value{ 17 | list of data.frames with the spatial coordinates of the points of interest 18 | and the respective position information 19 | } 20 | \description{ 21 | \code{posdeclist} works as \code{\link{posdec}} but not just for a single data.frame 22 | with individual points but for a list of data.frames 23 | } 24 | \examples{ 25 | df1 <- data.frame( 26 | x = rnorm(50), 27 | y = rnorm(50), 28 | z = rnorm(50) - 5 29 | ) 30 | 31 | df2 <- data.frame( 32 | x = rnorm(50), 33 | y = rnorm(50), 34 | z = rnorm(50) + 5 35 | ) 36 | 37 | lpoints <- list(df1, df2) 38 | 39 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 40 | 41 | hexadf1 <- data.frame( 42 | x = c(0, 1, 0, 4, 5, 5, 5, 5), 43 | y = c(1, 1, 4, 4, 1, 1, 4, 4), 44 | z = c(1, 5, 1, 6, 1, 5, 1, 3) 45 | ) 46 | 47 | hexadf2 <- data.frame( 48 | x = c(0, 1, 0, 4, 5, 5, 5, 5), 49 | y = c(1, 1, 4, 4, 1, 1, 4, 4), 50 | z = c(-1, -5, -1, -6, -1, -5, -1, -3) 51 | ) 52 | 53 | cx1 <- fillhexa(hexadf1, 0.1) 54 | cx2 <- fillhexa(hexadf2, 0.1) 55 | 56 | cubelist <- list(cx1, cx2) 57 | 58 | posdeclist(cubelist, maps) 59 | 60 | } 61 | \seealso{ 62 | Other posdecfuncs: \code{\link{posdec}} 63 | } 64 | \concept{posdecfuncs} 65 | -------------------------------------------------------------------------------- /tests/testthat/test_posdec.R: -------------------------------------------------------------------------------- 1 | context("Tests of function posdec") 2 | 3 | df1 <- data.frame( 4 | x = rnorm(50), 5 | y = rnorm(50), 6 | z = rnorm(50) - 5 7 | ) 8 | 9 | df2 <- data.frame( 10 | x = rnorm(50), 11 | y = rnorm(50), 12 | z = rnorm(50) + 5 13 | ) 14 | 15 | lpoints <- list(df1, df2) 16 | 17 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 18 | 19 | hexadf1 <- data.frame( 20 | x = c(0, 1, 0, 4, 5, 5, 5, 5), 21 | y = c(1, 1, 4, 4, 1, 1, 4, 4), 22 | z = c(1, 5, 1, 6, 1, 5, 1, 3) 23 | ) 24 | 25 | hexadf2 <- data.frame( 26 | x = c(0, 1, 0, 4, 5, 5, 5, 5), 27 | y = c(1, 1, 4, 4, 1, 1, 4, 4), 28 | z = c(-1, -5, -1, -6, -1, -5, -1, -3) 29 | ) 30 | 31 | cx1 <- fillhexa(hexadf1, 0.3) 32 | cx2 <- fillhexa(hexadf2, 0.3) 33 | 34 | cubelist <- list(cx1, cx2) 35 | 36 | res1 <- posdec(cx1, maps) 37 | res2 <- posdeclist(cubelist, maps) 38 | 39 | test_that( 40 | "the output of posdec is a data.frame", { 41 | expect_true( 42 | is.data.frame(res1) 43 | ) 44 | } 45 | ) 46 | 47 | test_that( 48 | "the output of posdeclist is a list", { 49 | expect_true( 50 | is.list(res2) 51 | ) 52 | } 53 | ) 54 | 55 | test_that( 56 | "the output of posdec has the correct amount of columns and colnames", { 57 | expect_equal( 58 | ncol(res1), 59 | 4 60 | ) 61 | expect_equal( 62 | colnames(res1), 63 | c("x", "y", "z", "pos") 64 | ) 65 | } 66 | ) 67 | 68 | test_that( 69 | "the output of posdec has the correct amount of rows", { 70 | expect_equal( 71 | nrow(res1), 72 | nrow(cx1) 73 | ) 74 | } 75 | ) 76 | 77 | test_that( 78 | "the output of posdeclist has the correct amount of result data.frames", { 79 | expect_equal( 80 | length(res2), 81 | length(cubelist) 82 | ) 83 | } 84 | ) 85 | 86 | test_that( 87 | "the output column pos of posdec has the correct range", { 88 | expect_true( 89 | all(range(res1$pos) %in% c(0, 1, 2)) 90 | ) 91 | } 92 | ) -------------------------------------------------------------------------------- /man/spitcenternat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spitcenternat} 4 | \alias{spitcenternat} 5 | \title{Center determination for rectangles whose tops and bottoms are defined by irregular surfaces (3D)} 6 | \usage{ 7 | spitcenternat(hex, maplist) 8 | } 9 | \arguments{ 10 | \item{hex}{data.frame with the 2D corners of the rectangle defined by four points} 11 | 12 | \item{maplist}{list of data.frames which contain the points that make up the surfaces} 13 | } 14 | \value{ 15 | data.frame with the spatial coordinates of the center points 16 | } 17 | \description{ 18 | \code{spitcenternat} first of all calculates the horizontal center of an input rectangle. 19 | Then it determines the vertical positions of the center points in relation to a surface stack. 20 | } 21 | \examples{ 22 | df1 <- data.frame( 23 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 24 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 25 | z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 26 | ) 27 | 28 | df2 <- data.frame( 29 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 30 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 31 | z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 32 | ) 33 | 34 | df3 <- data.frame( 35 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 36 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 37 | z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 38 | ) 39 | 40 | lpoints <- list(df1, df2, df3) 41 | 42 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 43 | 44 | hexatestdf <- data.frame( 45 | x = c(1, 1, 1, 1, 2, 2, 2, 2), 46 | y = c(0, 1, 0, 1, 0, 1, 0, 1) 47 | ) 48 | 49 | spitcenternat(hexatestdf, maps) 50 | 51 | } 52 | \seealso{ 53 | Other centerdetfuncs: \code{\link{spitcenternatlist}}, 54 | \code{\link{spitcenter}} 55 | } 56 | \concept{centerdetfuncs} 57 | -------------------------------------------------------------------------------- /src/spatiallong.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "helpfunc.h" 6 | 7 | //' Transformation of numeric matrices from wide to long format 8 | //' 9 | //' \code{spatiallong} transforms a set of two independent variables in vectors and a 10 | //' dependent variable in a wide matrix to a long matrix that combines the information. 11 | //' The result is exported as a data.frame. 12 | //' 13 | //' @param x vector of first independent variable. e.g. vector with x axis spatial points 14 | //' @param y vector of second independent variable. e.g. vector with y axis spatial points 15 | //' @param z matrix of dependent variable. e.g. matrix with z axis spatial points 16 | //' 17 | //' @return data.frame with three columns x, y and z 18 | //' 19 | //' @family transfuncs 20 | //' 21 | //' @examples 22 | //' x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 23 | //' y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 24 | //' z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 25 | //' 26 | //' sw <- spatialwide(x, y, z, digits = 3) 27 | //' 28 | //' spatiallong(sw$x, sw$y, sw$z) 29 | //' 30 | //' @export 31 | // [[Rcpp::export]] 32 | DataFrame spatiallong(NumericVector x , NumericVector y , NumericMatrix z) { 33 | 34 | // count z values that are not NA to create a res matrix of correct length 35 | int vcount = 0; 36 | for (int p1 = 0; p1 < z.ncol(); p1++) { 37 | for (int p2 = 0; p2 < z.nrow(); p2++) { 38 | if (!(NumericMatrix::is_na(z(p2, p1)))) { 39 | vcount++; 40 | } 41 | } 42 | } 43 | 44 | // create empty result matrix 45 | NumericMatrix res = na_matrix(vcount, 3); 46 | 47 | // fill result matrix 48 | int countp = 0; 49 | for (int p1 = 0; p1 < z.ncol(); p1++) { 50 | for (int p2 = 0; p2 < z.nrow(); p2++) { 51 | if (!(NumericMatrix::is_na(z(p2, p1)))) { 52 | res(countp, 0) = x(p1); 53 | res(countp, 1) = y(p2); 54 | res(countp, 2) = z(p2, p1); 55 | countp++; 56 | } 57 | } 58 | } 59 | 60 | return DataFrame::create(_["x"] = res(_, 0), _["y"] = res(_, 1), _["z"] = res(_, 2)); 61 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Project Status: Inactive – The project has reached a stable, usable state but is no longer being actively developed; support/maintenance will be provided as time allows.](https://www.repostatus.org/badges/latest/inactive.svg)](https://www.repostatus.org/#inactive) 2 | [![Travis-CI Build Status](https://travis-ci.org/ISAAKiel/recexcavAAR.svg?branch=master)](https://travis-ci.org/ISAAKiel/recexcavAAR) 3 | [![Coverage Status](https://img.shields.io/codecov/c/github/ISAAKiel/recexcavAAR/master.svg)](https://codecov.io/github/ISAAKiel/recexcavAAR?branch=master) 4 | [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/recexcavAAR)](https://cran.r-project.org/package=recexcavAAR) 5 | [![](http://cranlogs.r-pkg.org/badges/recexcavAAR)](https://CRAN.R-project.org/package=recexcavAAR) 6 | [![license](https://img.shields.io/badge/license-GPL%202-B50B82.svg)](https://www.r-project.org/Licenses/GPL-2) 7 | 8 | recexcavAAR 9 | ----------- 10 | 11 | R package for 3D reconstruction and analysis of excavations. It provides methods to reconstruct natural and artificial surfaces based on field measurements. This allows to spatially contextualize documented subunits and features. Intended to be part of a 3D visualization workflow. 12 | 13 | The following **vignettes** explain some of the implemented functions: 14 | 15 | * [**>>Semiautomatic spit attribution<<**](https://cran.r-project.org/web/packages/recexcavAAR/vignettes/recexcavAAR-vignette-1.html) 16 | * [**>>Trench visualisation<<**](https://cran.r-project.org/web/packages/recexcavAAR/vignettes/recexcavAAR-vignette-2.html) 17 | * [**>>Transforming coordinates<<**](https://cran.r-project.org/web/packages/recexcavAAR/vignettes/recexcavAAR-vignette-3.html) 18 | 19 | Installation 20 | ------------ 21 | 22 | Get the released version from CRAN: 23 | 24 | install.packages("recexcavAAR") 25 | 26 | Or the development version from github: 27 | 28 | # install.packages("devtools") 29 | devtools::install_github("ISAAKiel/recexcavAAR") 30 | 31 | History 32 | ------- 33 | 34 | The development of recexcavAAR began in [quantaar](https://github.com/ISAAKiel/quantaar) and was later moved. 35 | -------------------------------------------------------------------------------- /man/cootrans.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cootrans_func.R 3 | \name{cootrans} 4 | \alias{cootrans} 5 | \title{Tool for transforming local metric coordinates} 6 | \usage{ 7 | cootrans(pair_matrix, pm_column, data_matrix, dm_column, 8 | checking = FALSE, checkplot = TRUE) 9 | } 10 | \arguments{ 11 | \item{pair_matrix}{data.frame or matrix with pairs of local and corresponding absolute coordinates (Minimum two!)} 12 | 13 | \item{pm_column}{vector with numerical index of the columns in order: local x-value, local y-value, absolute x-value, absolute y-value} 14 | 15 | \item{data_matrix}{data.frame with local x- and y-values which schould be transformed.} 16 | 17 | \item{dm_column}{vector with numerical index of the columns in order: local x-value, local y-value.} 18 | 19 | \item{checking}{boolean switch to turn on the checking ability. Default: FALSE. If TRUE showes combined coordinate plots with indexed points and alters return of function.} 20 | 21 | \item{checkplot}{boolean switch to turn off the checking plot. Default: TRUE. Only matters if checking == TRUE.} 22 | } 23 | \value{ 24 | Original data.frame with additional columns containing the absolute x- and y-coordinates. In case of 'checking = TRUE' returns pair_matrix data.frame with additional columns of scale and rotation arc in degrees. 25 | } 26 | \description{ 27 | This function transforms local metric coordinates to absolute coordinates of referenced 28 | systems by use of a two dimensional four parameter Helmert transformation. This function does 29 | not cover the transformation of three dimensional points or transformation between two different 30 | datums. 31 | } 32 | \examples{ 33 | coord_data <- data.frame( 34 | loc_x = c(1,3,1,3), 35 | loc_y = c(1,1,3,3), 36 | abs_x = c(107.1,107,104.9,105), 37 | abs_y = c(105.1,107,105.1,106.9) 38 | ) 39 | 40 | data_table <- data.frame( 41 | x = c(1.5,1.2,1.6,2), 42 | y = c(1,5,2.1,2), 43 | type = c("flint","flint","pottery","bone") 44 | ) 45 | 46 | new_frame <- cootrans(coord_data, c(1,2,3,4), data_table, c(1,2)) 47 | 48 | check_data <- cootrans(coord_data, c(1,2,3,4), data_table, c(1,2), checking = TRUE) 49 | 50 | } 51 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' KT_data: Niveau measurements from the fictional trench of a excavation KT 2 | #' 3 | #' A dataset containing coordinates of niveau measurements of a fictional excavation KT with 4 | #' 4 spits. 5 | #' 6 | #' @format A data frame with 304 rows and 4 variables: 7 | #' \itemize{ 8 | #' \item id: IDs of individual measurements with the information about to which level 9 | #' they belong 10 | #' \item x: x axis coordinates of measurements 11 | #' \item y: y axis coordinates of measurements 12 | #' \item z: z axis coordinates of measurements 13 | #' } 14 | #' 15 | #' @family KT_data 16 | #' 17 | #' @name KT_spits 18 | NULL 19 | 20 | #' KT_data: Corner points of a 1m*1m raster within the trench of a fictional excavation KT 21 | #' 22 | #' A dataset containing horizontal coordinates of corner points of a 1m*1m raster within 23 | #' the rectangular trench (corner points of squares). 24 | #' 25 | #' @format A data frame with 63 rows and 2 variables: 26 | #' \itemize{ 27 | #' \item x: x axis coordinates of corner points 28 | #' \item y: y axis coordinates of corner points 29 | #' } 30 | #' 31 | #' @family KT_data 32 | #' 33 | #' @name KT_squarecorners 34 | NULL 35 | 36 | #' KT_data: Information about individual sherds of a reconstructed vessel from the trench 37 | #' of a fictional excavation KT 38 | #' 39 | #' A dataset containing spatial and contextual information for individual sherds of a single 40 | #' vessel. Some sherds were documented in the field with single find measurements. For the 41 | #' others only spit and square attribution is possible. 42 | #' 43 | #' @format A data frame with 7 rows and 7 variables: 44 | #' \itemize{ 45 | #' \item inv: Inventory numbers of sherds. KTF means single find with individual measurement, 46 | #' KTM means mass find without this precise information. 47 | #' \item spit: spits where the sherds were found 48 | #' \item square: squares where the sherds were found 49 | #' \item feature: features where the sherds were found 50 | #' \item x: x axis coordinates of sherds 51 | #' \item y: y axis coordinates of sherds 52 | #' \item z: z axis coordinates of sherds 53 | #' } 54 | #' 55 | #' @family KT_data 56 | #' 57 | #' @name KT_vessel 58 | NULL 59 | -------------------------------------------------------------------------------- /man/spitcenternatlist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{spitcenternatlist} 4 | \alias{spitcenternatlist} 5 | \title{Center determination for rectangles whose tops and bottoms are defined by irregular 6 | surfaces (3D) for multiple data.frames in a list} 7 | \usage{ 8 | spitcenternatlist(hexlist, maplist) 9 | } 10 | \arguments{ 11 | \item{hexlist}{list of data.frames with the 2D corners of the rectangles} 12 | 13 | \item{maplist}{list of data.frames which contain the points that make up the surfaces} 14 | } 15 | \value{ 16 | list of data.frames with the spatial coordinates of the center points 17 | } 18 | \description{ 19 | \code{spitcenternatlist} works as \code{\link{spitcenternat}} but not just for a 20 | single data.frame but for a list of data.frames 21 | } 22 | \examples{ 23 | df1 <- data.frame( 24 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 25 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 26 | z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 27 | ) 28 | 29 | df2 <- data.frame( 30 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 31 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 32 | z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 33 | ) 34 | 35 | df3 <- data.frame( 36 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 37 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 38 | z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 39 | ) 40 | 41 | lpoints <- list(df1, df2, df3) 42 | 43 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 44 | 45 | hexatestdf1 <- data.frame( 46 | x = c(1, 1, 1, 1, 2, 2, 2, 2), 47 | y = c(0, 1, 0, 1, 0, 1, 0, 1) 48 | ) 49 | 50 | hexatestdf2 <- data.frame( 51 | x = c(0, 0, 0, 0, 1, 1, 1, 1), 52 | y = c(0, 1, 0, 1, 0, 1, 0, 1) 53 | ) 54 | 55 | hexs <- list(hexatestdf1, hexatestdf2) 56 | 57 | spitcenternatlist(hexs, maps) 58 | 59 | } 60 | \seealso{ 61 | Other centerdetfuncs: \code{\link{spitcenternat}}, 62 | \code{\link{spitcenter}} 63 | } 64 | \concept{centerdetfuncs} 65 | -------------------------------------------------------------------------------- /tests/testthat/test_spatialwidelong.R: -------------------------------------------------------------------------------- 1 | context("Tests of functions spatialwide and spatiallong") 2 | 3 | x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 4 | y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 5 | z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 6 | 7 | sw <- spatialwide(x, y, z, digits = 3) 8 | 9 | sl <- spatiallong(sw$x, sw$y, sw$z) 10 | 11 | test_that( 12 | "the output of spatialwide is a list", { 13 | expect_true( 14 | is.list(sw) 15 | ) 16 | } 17 | ) 18 | 19 | test_that( 20 | "the output of spatiallong is a data.frame", { 21 | expect_true( 22 | is.data.frame(sl) 23 | ) 24 | } 25 | ) 26 | 27 | test_that( 28 | "the output of spatialwide has the correct elements", { 29 | expect_equal( 30 | names(sw), 31 | c("x", "y", "z") 32 | ) 33 | } 34 | ) 35 | 36 | test_that( 37 | "the output for z of spatialwide has the correct amount of rows and columns", { 38 | expect_equal( 39 | ncol(sw$z), 40 | length(unique(x)) 41 | ) 42 | expect_equal( 43 | nrow(sw$z), 44 | length(unique(y)) 45 | ) 46 | } 47 | ) 48 | 49 | test_that( 50 | "the output of spatiallong has the correct amount of rows and columns", { 51 | expect_equal( 52 | ncol(sl), 53 | 3 54 | ) 55 | expect_equal( 56 | nrow(sl), 57 | length(z[!is.na(z)]) 58 | ) 59 | } 60 | ) 61 | 62 | test_that( 63 | "the output of spatiallong has the correct colnames", { 64 | expect_equal( 65 | colnames(sl), 66 | c("x", "y", "z") 67 | ) 68 | } 69 | ) 70 | 71 | countersw <- list( 72 | x = as.numeric(c("1", "2", "3", "4")), 73 | y = as.numeric(c("1", "2", "3")), 74 | z = matrix(as.numeric(c(3, 4, 2, 3, NA, 5, 6, 3, NA ,NA, NA, 1)), 3, 4) 75 | ) 76 | 77 | test_that( 78 | "the output of spatialwide contains the correct values in an example setup", { 79 | expect_identical( 80 | sw, 81 | countersw 82 | ) 83 | } 84 | ) 85 | 86 | countersl <- data.frame( 87 | x = as.numeric(c("1", "1", "1", "2", "2", "3", "3", "4")), 88 | y = as.numeric(c("1", "2", "3", "1", "3", "1", "2", "3")), 89 | z = as.numeric(c("3", "4", "2", "3", "5", "6", "3", "1")) 90 | ) 91 | 92 | test_that( 93 | "the output of spatiallong contains the correct values in an example setup", { 94 | expect_identical( 95 | sl, 96 | countersl 97 | ) 98 | } 99 | ) -------------------------------------------------------------------------------- /R/geo_functions.R: -------------------------------------------------------------------------------- 1 | # Begin geo modelling functions --------------------------- 2 | 3 | #' Apply kriging \{kriging\} to a list of data.frames 4 | #' 5 | #' \code{kriging} \{kriging\} is a simple and highly optimized ordinary kriging algorithm to plot 6 | #' geographical data. This interface to the method allows to not just apply it to one data.frame but 7 | #' to a list of data.frames. The result is reduced to the data.frame with the predicted values. 8 | #' For a more detailed output \code{kriging} \{kriging\} has to be called for the individual input 9 | #' data.frames. 10 | #' 11 | #' @param plist List of data.frames with point coordinates 12 | #' @param x index of data.frame column with x-axis spatial points. Defaults to 1 13 | #' @param y index of data.frame column with y-axis spatial points. Defaults to 2 14 | #' @param z index of data.frame column with z-axis spatial points. Defaults to 3 15 | #' @param rdup switch to activate removal of double values for single horizontal positions in the input 16 | #' data.frames. Defaults to TRUE 17 | #' @param ... Arguments to be passed to method \code{kriging} \{kriging\} 18 | #' 19 | #' @return list with data.frames which contains the predicted values along with the coordinate covariates 20 | #' 21 | #' @examples 22 | #' df1 <- data.frame( 23 | #' x = rnorm(50), 24 | #' y = rnorm(50), 25 | #' z = rnorm(50) - 5 26 | #' ) 27 | #' 28 | #' df2 <- data.frame( 29 | #' x = rnorm(50), 30 | #' y = rnorm(50), 31 | #' z = rnorm(50) + 5 32 | #' ) 33 | #' 34 | #' lpoints <- list(df1, df2) 35 | #' 36 | #' surfacelist <- kriglist(lpoints, lags = 3, model = "spherical") 37 | #' 38 | #' @import kriging 39 | #' 40 | #' @export 41 | #' 42 | 43 | kriglist <- function(plist, x = 1, y = 2, z = 3, rdup = TRUE, ...) { 44 | # create output list 45 | maplist <- list() 46 | # loop to do kriging for all data.frames in the input list 47 | for (i in 1:length(plist)) { 48 | # remove duplicated values (x- & y-coordinate equal) 49 | if (rdup) { 50 | plist[[i]] <- plist[[i]][!duplicated(plist[[i]][,c(x,y)]),] 51 | } 52 | # kriging 53 | maplist[[i]] <- kriging::kriging( 54 | x = plist[[i]][,x], 55 | y = plist[[i]][,y], 56 | response = plist[[i]][,z], 57 | ... 58 | )$map 59 | } 60 | return(maplist) 61 | } 62 | 63 | # End geo modelling functions --------------------------- -------------------------------------------------------------------------------- /src/spatialwide.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "helpfunc.h" 6 | 7 | //' Transformation of numeric matrices from long to wide format 8 | //' 9 | //' Transforms a set of two independent and one dependent variables in vectors from a long 10 | //' to a wide format and exports this result as a list 11 | //' 12 | //' @param x vector of first independent variable. e.g. vector with x-axis spatial points 13 | //' @param y vector of second independent variable. e.g. vector with y-axis spatial points 14 | //' @param z vector of dependent variable. e.g. vector with z-axis spatial points 15 | //' @param digits integer indicating the number of decimal places to be used for rounding 16 | //' the dependent variables \code{x} and \code{y}. 17 | //' 18 | //' @return List with three elements: 19 | //' 20 | //' $x: vector with ascendingly sorted, unique values of the first independent variable \code{x} 21 | //' 22 | //' $y: vector with ascendingly sorted, unique values of the second independent variable \code{y} 23 | //' 24 | //' $z: matrix with the values of z for the defined combinations of \code{x} (columns) and 25 | //' \code{y} (rows) 26 | //' 27 | //' @family transfuncs 28 | //' 29 | //' @examples 30 | //' x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 31 | //' y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 32 | //' z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 33 | //' 34 | //' spatialwide(x, y, z, digits = 3) 35 | //' 36 | //' @export 37 | // [[Rcpp::export]] 38 | List spatialwide(NumericVector x , NumericVector y , NumericVector z, int digits) { 39 | 40 | // write input vectors to NumericMatrix 41 | NumericMatrix longdf(z.size(), 3); 42 | longdf(_, 0) = x; 43 | longdf(_, 1) = y; 44 | longdf(_, 2) = z; 45 | 46 | // define result vectors and matrix 47 | NumericVector xu = stl_sort(unique(x)); 48 | NumericVector yu = stl_sort(unique(y)); 49 | NumericMatrix widedf = na_matrix(yu.size(), xu.size()); 50 | 51 | // loop to fill wide matrix 52 | for (int p1 = 0; p1 < xu.size(); p1++) { 53 | for (int p2 = 0; p2 < yu.size(); p2++) { 54 | for (int p3 = 0; p3 < longdf.nrow(); p3++) { 55 | if (longdf(p3, 0) == xu[p1]) { 56 | if (longdf(p3, 1) == yu[p2]) { 57 | widedf(p2, p1) = longdf(p3, 2); 58 | } 59 | } 60 | } 61 | } 62 | } 63 | 64 | // prepare output list 65 | List res; 66 | res["x"] = round(xu, digits); 67 | res["y"] = round(yu, digits); 68 | res["z"] = widedf; 69 | 70 | return res; 71 | } -------------------------------------------------------------------------------- /playground/profile/Profile_10.dat: -------------------------------------------------------------------------------- 1 | 10683 1_KS_U X 155070.508 Y 517839.935 Z 80.977 2 | 10684 1_KS_X X 155070.973 Y 517840.010 Z 80.940 3 | 10685 1_KS_Y X 155070.483 Y 517840.014 Z 81.753 4 | 10686 1_GR_K_10 X 155069.868 Y 517839.851 Z 81.337 5 | 10687 1_GR_K_10 X 155070.427 Y 517839.964 Z 81.334 6 | 10688 1_GR_K_10 X 155070.501 Y 517839.931 Z 80.973 7 | 10689 1_GR_K_10 X 155071.062 Y 517839.980 Z 80.947 8 | 10690 0_K_10 X 155069.861 Y 517839.834 Z 81.335 9 | 10691 0_K_10 X 155070.003 Y 517839.900 Z 81.510 10 | 10692 0_K_10 X 155070.229 Y 517839.970 Z 81.748 11 | 10693 0_K_10 X 155070.758 Y 517840.050 Z 81.767 12 | 10694 0_K_10_$ X 155070.756 Y 517840.051 Z 81.767 13 | 10696 1_FG_K_10 X 155069.993 Y 517839.854 Z 81.372 14 | 10697 1_FG_K_10 X 155070.264 Y 517839.939 Z 81.736 15 | 10698 1_FG_K_10 X 155070.482 Y 517839.966 Z 81.735 16 | 10699 1_FG_K_10 X 155070.507 Y 517839.953 Z 81.349 17 | 10700 1_FG_K_10 X 155070.649 Y 517839.994 Z 81.578 18 | 10701 1_FG_K_10 X 155070.785 Y 517840.006 Z 81.741 19 | 10702 1_FG_K_10 X 155070.815 Y 517839.986 Z 81.127 20 | 10703 1_FG_K_10 X 155071.089 Y 517840.032 Z 81.314 21 | 10704 1_FG_K_10 X 155070.522 Y 517839.942 Z 81.003 22 | 10705 1_FG_K_10 X 155071.048 Y 517839.994 Z 80.993 23 | 11028 1-FG-K-10 X 155070.550 Y 517839.939 Z 81.012 24 | 11029 1-FG-K-10 X 155071.073 Y 517840.024 Z 81.001 25 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | /* 2 | Produced with: tools::package_native_routine_registration_skeleton(".") 3 | */ 4 | 5 | #include 6 | #include 7 | #include // for NULL 8 | #include 9 | 10 | /* FIXME: 11 | Check these declarations against the C/Fortran source code. 12 | */ 13 | 14 | /* .Call calls */ 15 | extern SEXP _recexcavAAR_draw_circle(SEXP, SEXP, SEXP, SEXP, SEXP); 16 | extern SEXP _recexcavAAR_draw_sphere(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 17 | extern SEXP _recexcavAAR_fillhexa(SEXP, SEXP); 18 | extern SEXP _recexcavAAR_pnp(SEXP, SEXP, SEXP, SEXP); 19 | extern SEXP _recexcavAAR_pnpmulti(SEXP, SEXP, SEXP, SEXP); 20 | extern SEXP _recexcavAAR_posdec(SEXP, SEXP); 21 | extern SEXP _recexcavAAR_posdeclist(SEXP, SEXP); 22 | extern SEXP _recexcavAAR_rescale(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 23 | extern SEXP _recexcavAAR_rotate(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 24 | extern SEXP _recexcavAAR_spatiallong(SEXP, SEXP, SEXP); 25 | extern SEXP _recexcavAAR_spatialwide(SEXP, SEXP, SEXP, SEXP); 26 | extern SEXP _recexcavAAR_spitcenter(SEXP); 27 | extern SEXP _recexcavAAR_spitcenternat(SEXP, SEXP); 28 | extern SEXP _recexcavAAR_spitcenternatlist(SEXP, SEXP); 29 | 30 | static const R_CallMethodDef CallEntries[] = { 31 | {"_recexcavAAR_draw_circle", (DL_FUNC) &_recexcavAAR_draw_circle, 5}, 32 | {"_recexcavAAR_draw_sphere", (DL_FUNC) &_recexcavAAR_draw_sphere, 6}, 33 | {"_recexcavAAR_fillhexa", (DL_FUNC) &_recexcavAAR_fillhexa, 2}, 34 | {"_recexcavAAR_pnp", (DL_FUNC) &_recexcavAAR_pnp, 4}, 35 | {"_recexcavAAR_pnpmulti", (DL_FUNC) &_recexcavAAR_pnpmulti, 4}, 36 | {"_recexcavAAR_posdec", (DL_FUNC) &_recexcavAAR_posdec, 2}, 37 | {"_recexcavAAR_posdeclist", (DL_FUNC) &_recexcavAAR_posdeclist, 2}, 38 | {"_recexcavAAR_rescale", (DL_FUNC) &_recexcavAAR_rescale, 6}, 39 | {"_recexcavAAR_rotate", (DL_FUNC) &_recexcavAAR_rotate, 9}, 40 | {"_recexcavAAR_spatiallong", (DL_FUNC) &_recexcavAAR_spatiallong, 3}, 41 | {"_recexcavAAR_spatialwide", (DL_FUNC) &_recexcavAAR_spatialwide, 4}, 42 | {"_recexcavAAR_spitcenter", (DL_FUNC) &_recexcavAAR_spitcenter, 1}, 43 | {"_recexcavAAR_spitcenternat", (DL_FUNC) &_recexcavAAR_spitcenternat, 2}, 44 | {"_recexcavAAR_spitcenternatlist", (DL_FUNC) &_recexcavAAR_spitcenternatlist, 2}, 45 | {NULL, NULL, 0} 46 | }; 47 | 48 | void R_init_recexcavAAR(DllInfo *dll) 49 | { 50 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 51 | R_useDynamicSymbols(dll, FALSE); 52 | } -------------------------------------------------------------------------------- /tests/testthat/test_spitcenternat.R: -------------------------------------------------------------------------------- 1 | context("Tests of functions spitcenternat and spitcenternatlist") 2 | 3 | df1 <- data.frame( 4 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 5 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 6 | z = c(rep(0.9, 6), rep(0.9, 14), rep(1.3, 14), rep(1.2, 6)) 7 | ) 8 | 9 | df2 <- data.frame( 10 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 11 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 12 | z = c(rep(0.6, 6), rep(0.6, 14), rep(1.0, 14), rep(0.9, 6)) 13 | ) 14 | 15 | df3 <- data.frame( 16 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 17 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 18 | z = c(rep(0.3, 6), rep(0.3, 14), rep(0.7, 14), rep(0.6, 6)) 19 | ) 20 | 21 | lpoints <- list(df1, df2, df3) 22 | 23 | maps <- kriglist(lpoints, lags = 3, model = "spherical") 24 | 25 | hexatestdf1 <- data.frame( 26 | x = c(1, 1, 1, 1, 2, 2, 2, 2), 27 | y = c(0, 1, 0, 1, 0, 1, 0, 1) 28 | ) 29 | 30 | hexatestdf2 <- data.frame( 31 | x = c(0, 0, 0, 0, 1, 1, 1, 1), 32 | y = c(0, 1, 0, 1, 0, 1, 0, 1) 33 | ) 34 | 35 | hexs <- list(hexatestdf1, hexatestdf2) 36 | 37 | sn <- spitcenternat(hexatestdf1, maps) 38 | snl <- spitcenternatlist(hexs, maps) 39 | 40 | 41 | 42 | test_that( 43 | "the output of spitcenternat is a data.frame", { 44 | expect_true( 45 | is.data.frame(sn) 46 | ) 47 | } 48 | ) 49 | 50 | test_that( 51 | "the output of spitcenternatlist is a list", { 52 | expect_true( 53 | is.list(snl) 54 | ) 55 | } 56 | ) 57 | 58 | test_that( 59 | "the output of spitcenternat has the correct amount of rows and columns and the correct colnames", { 60 | expect_equal( 61 | ncol(sn), 62 | 3 63 | ) 64 | expect_equal( 65 | nrow(sn), 66 | length(maps) - 1 67 | ) 68 | expect_equal( 69 | colnames(sn), 70 | c("x", "y", "z") 71 | ) 72 | } 73 | ) 74 | 75 | test_that( 76 | "the output of spitcenternatlist has the correct length", { 77 | expect_equal( 78 | length(snl), 79 | length(hexs) 80 | ) 81 | } 82 | ) 83 | 84 | countersnl <- list( 85 | data.frame( 86 | x = c(1.5, 1.5), 87 | y = c(0.5, 0.5), 88 | z = c(0.944, 0.644) 89 | ), 90 | data.frame( 91 | x = c(0.5, 0.5), 92 | y = c(0.5, 0.5), 93 | z = c(0.923, 0.623) 94 | ) 95 | ) 96 | 97 | snl[[1]]$z <- round(snl[[1]]$z, 3) 98 | snl[[2]]$z <- round(snl[[2]]$z, 3) 99 | 100 | test_that( 101 | "the output of spitcenternatlist (and spitcenternat) is as expected", { 102 | expect_identical( 103 | snl, 104 | countersnl 105 | ) 106 | } 107 | ) -------------------------------------------------------------------------------- /src/pointinpoly.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include "helpfunc.h" 3 | using namespace Rcpp; 4 | 5 | //' Check if a point is within a polygon (2D) 6 | //' 7 | //' @description 8 | //' \code{pnp} is able to determine if a point is within a polygon in 2D space. 9 | //' The polygon is described by its corner points. The points must be in a correct 10 | //' drawing order. 11 | //' 12 | //' Based on this solution: 13 | //' Copyright (c) 1970-2003, Wm. Randolph Franklin 14 | //' \url{http://wrf.ecse.rpi.edu/pmwiki/pmwiki.php/Main/Software#toc24} 15 | //' 16 | //' @details 17 | //' For discussion see: \url{http://stackoverflow.com/questions/217578/how-can-i-determine-whether-a-2d-point-is-within-a-polygon/2922778#2922778} 18 | //' 19 | //' @param vertx vector of x axis values of polygon corner points 20 | //' @param verty vector of y axis values of polygon corner points 21 | //' @param testx x axis value of point of interest 22 | //' @param testy y axis value of point of interest 23 | //' 24 | //' @return boolean value - TRUE, if the point is within the polygon. Otherwise FALSE. 25 | //' 26 | //' @family pnpfuncs 27 | //' 28 | //' @examples 29 | //' df <- data.frame( 30 | //' x = c(1,1,2,2), 31 | //' y = c(1,2,1,2) 32 | //' ) 33 | //' 34 | //' pnp(df$x, df$y, 1.5, 1.5) 35 | //' pnp(df$x, df$y, 2.5, 2.5) 36 | //' 37 | //' # caution: false-negatives in edge-cases: 38 | //' pnp(df$x, df$y, 2, 1.5) 39 | //' 40 | //' @export 41 | // [[Rcpp::export]] 42 | bool pnp(NumericVector vertx, NumericVector verty, float testx, float testy) { 43 | 44 | int nvert = vertx.size(); 45 | bool c = FALSE; 46 | int i, j = 0; 47 | for (i = 0, j = nvert-1; i < nvert; j = i++) { 48 | if ( ((verty[i]>testy) != (verty[j]>testy)) && 49 | (testx < (vertx[j]-vertx[i]) * (testy-verty[i]) / (verty[j]-verty[i]) + vertx[i]) ) 50 | c = !c; 51 | } 52 | 53 | return c; 54 | } 55 | 56 | //' Check if multiple points are within a polygon (2D) 57 | //' 58 | //' @description 59 | //' \code{pnpmulti} works as \code{\link{pnp}} but for multiple points. 60 | //' 61 | //' @param vertx vector of x axis values of polygon corner points 62 | //' @param verty vector of y axis values of polygon corner points 63 | //' @param testx vector of x axis values of points of interest 64 | //' @param testy vector of y axis values of points of interest 65 | //' 66 | //' @return vector with boolean values - TRUE, if the respective point is within the polygon. 67 | //' Otherwise FALSE. 68 | //' 69 | //' @examples 70 | //' polydf <- data.frame( 71 | //' x = c(1,1,2,2), 72 | //' y = c(1,2,1,2) 73 | //' ) 74 | //' 75 | //' testdf <- data.frame( 76 | //' x = c(1.5, 2.5), 77 | //' y = c(1.5, 2.5) 78 | //' ) 79 | //' 80 | //' pnpmulti(polydf$x, polydf$y, testdf$x, testdf$y) 81 | //' 82 | //' @family pnpfuncs 83 | //' 84 | //' @export 85 | // [[Rcpp::export]] 86 | LogicalVector pnpmulti(NumericVector vertx, NumericVector verty, NumericVector testx, NumericVector testy){ 87 | 88 | int n = testx.size(); 89 | LogicalVector deci(n); 90 | for(int i = 0; i < n; i++) { 91 | deci(i) = pnp(vertx, verty, testx(i), testy(i)); 92 | } 93 | 94 | return deci; 95 | } -------------------------------------------------------------------------------- /playground/profile/Profile_8.dat: -------------------------------------------------------------------------------- 1 | 10452 1_KS_U X 155071.343 Y 517840.391 Z 81.195 2 | 10453 1_KS_X X 155071.748 Y 517840.600 Z 81.221 3 | 10454 1_KS_Y X 155071.335 Y 517840.424 Z 81.738 4 | 10455 1_GR_K_8 X 155071.291 Y 517840.393 Z 81.838 5 | 10456 1_GR_K_8 X 155071.269 Y 517840.366 Z 81.709 6 | 10457 1_GR_K_8 X 155071.165 Y 517840.236 Z 81.220 7 | 10458 1_GR_K_8 X 155071.845 Y 517840.641 Z 81.237 8 | 10459 1_GR_K_8 X 155071.819 Y 517840.645 Z 81.328 9 | 10460 1_GR_K_8 X 155071.905 Y 517840.885 Z 81.458 10 | 10461 1_GR_K_8 X 155071.887 Y 517840.742 Z 81.628 11 | 10462 0_K_8 X 155071.919 Y 517840.820 Z 81.608 12 | 10463 0_K_8 X 155071.731 Y 517840.645 Z 81.798 13 | 10464 0_K_8 X 155071.559 Y 517840.546 Z 81.804 14 | 10465 0_K_8 X 155071.442 Y 517840.487 Z 81.733 15 | 10466 0_K_8 X 155071.330 Y 517840.422 Z 81.750 16 | 10467 0_K_8 X 155071.294 Y 517840.405 Z 81.825 17 | 10468 0_K_8_$ X 155071.296 Y 517840.411 Z 81.823 18 | 10469 1_FG_K_8 X 155071.295 Y 517840.393 Z 81.761 19 | 10470 1_FG_K_8 X 155071.337 Y 517840.402 Z 81.503 20 | 10471 1_FG_K_8 X 155071.604 Y 517840.570 Z 81.785 21 | 10472 1_FG_K_8 X 155071.616 Y 517840.560 Z 81.530 22 | 10473 1_FG_K_8 X 155071.804 Y 517840.630 Z 81.254 23 | 10474 1_FG_K_8 X 155071.856 Y 517840.701 Z 81.645 24 | 10475 1_FG_K_8 X 155071.855 Y 517840.700 Z 81.645 25 | 10476 1_FG_K_8 X 155071.603 Y 517840.569 Z 81.785 26 | 10477 1_FG_K_8 X 155071.616 Y 517840.560 Z 81.530 27 | 10478 1_FG_K_8 X 155071.804 Y 517840.630 Z 81.254 28 | 10479 1_FG_K_8 X 155071.519 Y 517840.495 Z 81.222 29 | 10480 1_FG_K_8 X 155071.336 Y 517840.402 Z 81.504 30 | 10481 1_FG_K_8 X 155071.189 Y 517840.310 Z 81.215 -------------------------------------------------------------------------------- /playground/profile/profile_prep.R: -------------------------------------------------------------------------------- 1 | #Script for profile preparation -> distances/size stay the same, but the absolute position of the 2 | #profile is changed 3 | 4 | library(dplyr) 5 | 6 | # input is a 7 | # 0: normal profile (N-S, E-W), 1: diagonal profile (NE-SW, etc.), 8 | diagswitch <- 1 9 | 10 | 11 | #### load data #### 12 | input <- read.table( 13 | "playground/profile/Profile_NW3.dat", 14 | stringsAsFactors = FALSE 15 | ) 16 | M1 <- input[,c(4,6,8,2)] 17 | 18 | rgl::plot3d(M1$V4, M1$V6, M1$V8) 19 | 20 | M <- input[,c(4,6)] 21 | 22 | 23 | 24 | 25 | 26 | #### rotation - if necessary #### 27 | #Concept: http://stackoverflow.com/questions/15463462/rotate-graph-by-angle 28 | 29 | #calculate rotation angle 30 | alpha <- -atan( 31 | (M[1,2]-tail(M,1)[,2]) / 32 | (M[1,1]-tail(M,1)[,1]) 33 | ) 34 | 35 | #rotation matrix 36 | rotm <- matrix(c( 37 | cos(alpha), 38 | sin(alpha), 39 | -sin(alpha), 40 | cos(alpha)), 41 | ncol=2 42 | ) 43 | 44 | #shift, rotate, shift back 45 | #shift points, so that turning point is (0,0) 46 | M2.1 <- t(t(M)-c(M[1,1],M[1,2])) 47 | plot(M2.1,col="blue") 48 | #rotate 49 | M2.2 <- t(rotm %*% (t(M2.1))) 50 | points(M2.2,col="green") 51 | # #shift back 52 | # M2.3 <- t(t(M2.2)+c(M[1,1],M[1,2])) 53 | # plot(M2.3,col="red") 54 | 55 | #build export file 56 | finalM <- data.frame(X = M2.2[,1], Y = M2.2[,2], Z = M1[,3], Code = M1[,4]) 57 | #plot(finalM$X, finalM$Y) 58 | #plot(finalM$X, finalM$Z) 59 | rgl::plot3d(finalM) 60 | 61 | 62 | 63 | 64 | #### Transformation #### 65 | 66 | # diagonal decision 67 | if (diagswitch == 1) { 68 | M2 <- finalM 69 | } else if (diagswitch == 0) { 70 | M2 <- data.frame(X = M1[,1]-min(M1[,1]), Y = M1[,2]-min(M1[,2]), Z = M1[,3], Code = M1[,4]) 71 | } 72 | rgl::plot3d(M2) 73 | 74 | 75 | #check position and orientation of the profile with the measurements of KS-U and KS-X 76 | #set up a perfectly prepared data.frame for each case (including mirroring of the profile if necessary) 77 | if (diff(c(min(M2$X),max(M2$X))) < diff(c(min(M2$Y),max(M2$Y)))) { 78 | print("Profile: |") 79 | if (filter(M2, Code == "1-KS-U")$Y < filter(M2, Code == "1-KS-X")$Y) { 80 | print("The profile is S-N-oriented - West Profile") 81 | M3 <- data.frame(Code = M2$Code, X = M2$Y, Y = M2$Z, Deviation = M2$X) 82 | } else { 83 | print("The profile is N-S-oriented - East Profile") 84 | M3 <- data.frame(Code = M2$Code, X = abs(M2$Y-max(M2$Y)), Y = M2$Z, Deviation = M2$X) 85 | } 86 | } else { 87 | print("Profile: --") 88 | if (filter(M2, Code == "1-KS-U")$X < filter(M2, Code == "1-KS-X")$X) { 89 | print("The profile is W-E-oriented - North Profile") 90 | M3 <- data.frame(Code = M2$Code, X = M2$X, Y = M2$Z, Deviation = M2$Y) 91 | } else { 92 | print("The profile is E-W-oriented - South Profile") 93 | M3 <- data.frame(Code = M2$Code, X = abs(M2$X-max(M2$X)), Y = M2$Z, Deviation = M2$Y) 94 | } 95 | } 96 | 97 | #add point numbers again 98 | M4 <- data.frame(M3, Number = input$V1) 99 | 100 | #format data.frame and write into file system 101 | M5 <- format(M4, nsmall=3) 102 | # write.table( 103 | # M5, 104 | # file = "playground/profile/Profile_NW3_prep.txt", 105 | # sep="\t", 106 | # row.names = FALSE, 107 | # quote = FALSE 108 | # ) 109 | -------------------------------------------------------------------------------- /src/helpfunc.h: -------------------------------------------------------------------------------- 1 | // small helping funtions to be used in the c++ code 2 | 3 | #include 4 | #include 5 | using namespace Rcpp; 6 | 7 | 8 | #ifndef __UTILITIES__ 9 | #define __UTILITIES__ 10 | 11 | //' create NumericMatrix filled with NAs 12 | //' 13 | //' @param r rows of matrix 14 | //' @param r cols of matrix 15 | //' 16 | //' @return NumericMatrix of correct size filled with NAs 17 | 18 | inline NumericMatrix na_matrix(int r, int c){ 19 | NumericMatrix m(r,c) ; 20 | std::fill( m.begin(), m.end(), NumericVector::get_na() ) ; 21 | return m ; 22 | } 23 | 24 | //' sort NumericVector 25 | //' 26 | //' @param x NumericVector of interest 27 | //' 28 | //' @return sorted NumericVector 29 | 30 | inline NumericVector stl_sort(NumericVector x) { 31 | NumericVector y = clone(x); 32 | std::sort(y.begin(), y.end()); 33 | return y; 34 | } 35 | 36 | //' find maximum of a NumericVector 37 | //' 38 | //' @param x NumericVector of interest 39 | //' 40 | //' @return value of highest value in NumericVector 41 | 42 | inline double maxv(NumericVector x){ 43 | // changing vars 44 | double maxi = x(0); 45 | // search loop 46 | for (int p = 0; p < x.size(); p++) { 47 | if (x(p) >= maxi) { 48 | maxi = x(p); 49 | } 50 | } 51 | // output 52 | return maxi; 53 | } 54 | 55 | //' find id of maximum of a NumericVector 56 | //' 57 | //' @param x NumericVector of interest 58 | //' 59 | //' @return id of highest value in NumericVector 60 | 61 | inline int maxid(NumericVector x){ 62 | // changing vars 63 | double maxi = x(0); 64 | int id = 0; 65 | // search loop 66 | for (int p = 0; p < x.size(); p++) { 67 | if (x(p) >= maxi) { 68 | maxi = x(p); 69 | id = p; 70 | } 71 | } 72 | // output 73 | return id; 74 | } 75 | 76 | //' find minimum of a NumericVector 77 | //' 78 | //' @param x NumericVector of interest 79 | //' 80 | //' @return value of smallest value in NumericVector 81 | 82 | inline double minv(NumericVector x){ 83 | // changing vars 84 | double mini = x(0); 85 | // search loop 86 | for (int p = 0; p < x.size(); p++) { 87 | if (x(p) <= mini) { 88 | mini = x(p); 89 | } 90 | } 91 | // output 92 | return mini; 93 | } 94 | 95 | //' find id of maximum of a NumericVector 96 | //' 97 | //' @param x NumericVector of interest 98 | //' 99 | //' @return id of highest value in NumericVector 100 | 101 | inline int minid(NumericVector x){ 102 | // changing vars 103 | double mini = x(0); 104 | int id = 0; 105 | // search loop 106 | for (int p = 0; p < x.size(); p++) { 107 | if (x(p) <= mini) { 108 | mini = x(p); 109 | id = p; 110 | } 111 | } 112 | // output 113 | return id; 114 | } 115 | 116 | //' 2D distance (pythagoras) between two points 117 | //' 118 | //' @param x1 x axis value of first point 119 | //' @param x2 x axis value of second point 120 | //' @param y1 y axis value of first point 121 | //' @param y2 y axis value of second point 122 | //' 123 | //' @return distance value 124 | 125 | inline double pyth (double x1, double y1, double x2, double y2) { 126 | double x = x1 - x2; 127 | double y = y1 - y2; 128 | double dist = pow(x, 2) + pow(y, 2); 129 | dist = sqrt(dist); 130 | return dist; 131 | } 132 | 133 | 134 | #endif //__UTILITIES__ -------------------------------------------------------------------------------- /src/fillhexa.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | NumericMatrix makematrix(NumericVector vec, int lres3){ 9 | NumericMatrix result(lres3, 3); 10 | for (int p1 = 0; p1 < 3; p1++) { 11 | for (int p2 = 0; p2 < lres3; p2++) { 12 | result(p2,p1) = vec(p1); 13 | } 14 | } 15 | return result; 16 | } 17 | 18 | //' Fills hexahedrons with a regular point raster (3D) 19 | //' 20 | //' @description 21 | //' A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 22 | //' \code{fillhexa} allows to fill such a shape with a regular point raster. 23 | //' 24 | //' @details 25 | //' See \url{https://stackoverflow.com/questions/36115215/filling-a-3d-body-with-a-systematic-point-raster} 26 | //' for a description of the function and how it was developed. 27 | //' 28 | //' @param hex dataframe with three columns and eight rows to define a hexahedron by its corner 29 | //' point coordinates x, y and z 30 | //' @param res numeric value > 0 and <= 1 for the resolution of the point raster 31 | //' 32 | //' @return data.frame with the spatial coordinates of the resulting points of the grid 33 | //' 34 | //' @examples 35 | //' hexatestdf <- data.frame( 36 | //' x = c(0,1,0,4,5,5,5,5), 37 | //' y = c(1,1,4,4,1,1,4,4), 38 | //' z = c(4,8,4,9,4,8,4,6) 39 | //' ) 40 | //' 41 | //' cx = fillhexa(hexatestdf, 0.1) 42 | //' 43 | //' #library(rgl) 44 | //' #plot3d( 45 | //' # cx[,1], cx[,2], cx[,3], 46 | //' # type = "p", 47 | //' # xlab = "x", ylab = "y", zlab = "z" 48 | //' #) 49 | //' 50 | //' @export 51 | // [[Rcpp::export]] 52 | DataFrame fillhexa(DataFrame hex, double res){ 53 | 54 | Function asMatrix("as.matrix"); 55 | 56 | SEXP hex2mid = hex; 57 | NumericMatrix hexa = asMatrix(hex2mid); 58 | 59 | // check, if res is between 0 and 1 60 | 61 | // check, if res is 1/res != int 62 | 63 | // check if hexa has the right form 64 | 65 | // ... 66 | 67 | // create new coordinate system (u,v,w) 68 | int lres = (1/res)+1; 69 | NumericVector resvec(lres); 70 | for (int p1 = 0; p1 < lres; p1++) { 71 | resvec(p1) = res*p1; 72 | } 73 | 74 | int lres2 = pow((double)lres, 2.0); 75 | int lres3 = pow((double)lres, 3.0); 76 | 77 | // u 78 | NumericVector u(lres3); 79 | int counter1 = 0; 80 | int counter2 = 0; 81 | int p2 = 0; 82 | for (int p1 = 0; p1 < lres3; p1++) { 83 | counter1++; 84 | counter2++; 85 | u(p1) = resvec(p2); 86 | if (counter1 == lres){ 87 | counter1 = 0; 88 | p2++; 89 | if (counter2 == lres2){ 90 | counter2 = 0; 91 | p2 = 0; 92 | } 93 | } 94 | } 95 | 96 | // v 97 | NumericVector v(lres3); 98 | counter1 = 0; 99 | p2 = 0; 100 | for (int p1 = 0; p1 < lres3; p1++) { 101 | counter1++; 102 | v(p1) = resvec(p2); 103 | if (counter1 == lres2){ 104 | counter1 = 0; 105 | p2++; 106 | } 107 | } 108 | 109 | // w 110 | NumericVector w(lres3); 111 | counter1 = 0; 112 | p2 = 0; 113 | for (int p1 = 0; p1 < lres3; p1++) { 114 | counter1++; 115 | w(p1) = resvec(p2); 116 | p2++; 117 | if (counter1 == lres){ 118 | counter1 = 0; 119 | p2 = 0; 120 | } 121 | } 122 | 123 | // transformation 124 | NumericVector A = hexa(0,_); 125 | NumericVector B = hexa(1,_) - A; 126 | NumericVector C = hexa(2,_) - A; 127 | NumericVector D = hexa(4,_) - A; 128 | NumericVector E = hexa(3,_) - A - B - C; 129 | NumericVector F = hexa(5,_) - A - B - D; 130 | NumericVector G = hexa(6,_) - A - C - D; 131 | NumericVector H = hexa(7,_) - A - B - C - D - E - F - G; 132 | 133 | NumericMatrix Am = makematrix(A, lres3); 134 | NumericMatrix Bm = makematrix(B, lres3); 135 | NumericMatrix Cm = makematrix(C, lres3); 136 | NumericMatrix Dm = makematrix(D, lres3); 137 | NumericMatrix Em = makematrix(E, lres3); 138 | NumericMatrix Fm = makematrix(F, lres3); 139 | NumericMatrix Gm = makematrix(G, lres3); 140 | NumericMatrix Hm = makematrix(H, lres3); 141 | 142 | for (int p1 = 0; p1 < lres3; p1++) { 143 | Bm(p1,_) = Bm(p1,_) * u(p1); 144 | Cm(p1,_) = Cm(p1,_) * v(p1); 145 | Dm(p1,_) = Dm(p1,_) * w(p1); 146 | Em(p1,_) = Em(p1,_) * u(p1) * v(p1); 147 | Fm(p1,_) = Fm(p1,_) * u(p1) * w(p1); 148 | Gm(p1,_) = Gm(p1,_) * v(p1) * w(p1); 149 | Hm(p1,_) = Hm(p1,_) * u(p1) * v(p1) * w(p1); 150 | } 151 | 152 | NumericMatrix final(lres3, 3); 153 | 154 | for (int p1 = 0; p1 < lres3; p1++) { 155 | final(p1,_) = Am(p1,_) + Bm(p1,_) + Cm(p1,_) + Dm(p1,_) + Em(p1,_) + Fm(p1,_) + Gm(p1,_) + Hm(p1,_); 156 | } 157 | 158 | NumericVector x = final(_,0); 159 | NumericVector y = final(_,1); 160 | NumericVector z = final(_,2); 161 | 162 | // output 163 | return DataFrame::create(_["x"] = x, _["y"] = y, _["z"] = z); 164 | } -------------------------------------------------------------------------------- /tests/testthat/test_cootrans.R: -------------------------------------------------------------------------------- 1 | context("Tests of coordinate transformation function") 2 | 3 | coord_data <- data.frame( 4 | loc_x = c(1, 3, 1, 3), 5 | loc_y = c(1, 1, 3, 3), 6 | abs_x = c(107.1, 107, 104.9, 105), 7 | abs_y = c(105.1, 107, 105.1, 106.9) 8 | ) 9 | 10 | data_table <- data.frame( 11 | x = c(1.5, 1.2, 1.6, 2), 12 | y = c(1, 5, 2.1, 2), 13 | type = c("flint","flint","pottery","bone") 14 | ) 15 | 16 | new_frame <- suppressMessages( 17 | cootrans( 18 | pair_matrix = coord_data, 19 | pm_column = c(1, 2, 3, 4), 20 | data_matrix = data_table, 21 | dm_column = c(1, 2), 22 | checkplot = FALSE 23 | ) 24 | ) 25 | 26 | wrong_data <- data.frame( 27 | loc_x = c(1, 3, 1, 3), 28 | loc_y = c(1, 3, 3, 1), 29 | abs_x = c(107.1, 107, 104.9, 105), 30 | abs_y = c(105.1, 107, 105.1, 106.9) 31 | ) 32 | 33 | check_data <- suppressMessages( 34 | cootrans( 35 | pair_matrix = wrong_data, 36 | pm_column = c(1, 2, 3, 4), 37 | data_matrix = data_table, 38 | dm_column = c(1, 2), 39 | checking = TRUE, 40 | checkplot = FALSE 41 | ) 42 | ) 43 | ##### 44 | ##### 45 | 46 | test_that( 47 | "the output of the transformation function is a 48 | data.frame", { 49 | expect_true( 50 | is.data.frame(new_frame) 51 | ) 52 | } 53 | ) 54 | 55 | test_that( 56 | "the output data.frame of the transformation function 57 | has the correct colnames", { 58 | expect_equal( 59 | colnames(new_frame), 60 | c("x", "y", "type", "abs_x", "abs_y") 61 | ) 62 | } 63 | ) 64 | 65 | test_that( 66 | "the input data.frames have minimum number of columns", { 67 | expect_gte(length(colnames(coord_data)), 4) 68 | expect_gte(length(colnames(data_table)), 2) 69 | } 70 | ) 71 | 72 | test_that( 73 | "the output data.frame has two additional columns", { 74 | expect_equal( 75 | length(colnames(new_frame)), 76 | length(colnames(data_table))+2 77 | ) 78 | } 79 | ) 80 | 81 | test_that( 82 | "wrong assignement of coordinates returns a warning 83 | message", { 84 | expect_warning( 85 | cootrans(wrong_data, c(1, 2, 3, 4), data_table, c(1, 2), 86 | checkplot = FALSE) 87 | ) 88 | } 89 | ) 90 | 91 | test_that( 92 | "with testing=TRUE resulting check_data data.frame is the 93 | original data.frame with two additional columns", { 94 | expect_identical( 95 | wrong_data, 96 | check_data[,1:(length(colnames(check_data))-2)] 97 | ) 98 | } 99 | ) 100 | 101 | test_that( 102 | "with testing=TRUE output data.frame has the correct 103 | colnames", { 104 | expect_equal( 105 | colnames(check_data), 106 | c("loc_x", "loc_y", "abs_x", "abs_y", 107 | "scalation", "rotation") 108 | ) 109 | } 110 | ) 111 | 112 | test_that( 113 | "transformation runs correctly. And even with points 114 | corresponding with the centroids (previous scale-NaN Bug)", { 115 | simple_coord <- data.frame( 116 | loc_x = c(1, 3, 1, 3, 2), 117 | loc_y = c(1, 1, 3, 3, 2), 118 | abs_x = c(7, 7, 5, 5, 6), 119 | abs_y = c(5, 7, 5, 7, 6) 120 | ) 121 | test_data <- data.frame( 122 | index = c(1, 2, 3, 4), 123 | x = c(3, 6, 4, 2), 124 | y = c(2, 1, 4, 2) 125 | ) 126 | # the expected results where calculated using the 127 | # original python-script 128 | exp_frame <- data.frame( 129 | test_data, 130 | abs_x = c(6, 7, 4, 6), 131 | abs_y = c(7, 10, 8, 6) 132 | ) 133 | exp_check <- data.frame( 134 | simple_coord, 135 | scalation = c(1, 1, 1, 1, NaN), 136 | rotation = c(270, 270, 270, 270, NaN) 137 | ) 138 | 139 | expect_equal( 140 | cootrans(simple_coord, c(1,2,3,4), test_data, c(2,3), 141 | checkplot = FALSE), 142 | exp_frame 143 | ) 144 | 145 | expect_equal( 146 | cootrans(simple_coord, c(1,2,3,4), test_data, c(2,3), 147 | checking = TRUE, checkplot = FALSE), 148 | exp_check 149 | ) 150 | } 151 | ) 152 | 153 | test_that( 154 | "transformation runs correctly. One points corresponding 155 | with the centroid (!div0 problem)", { 156 | simple_coord <- data.frame( 157 | loc_x = c(1, 3, 1, 3, 2), 158 | loc_y = c(1, 1, 3, 3, 2), 159 | abs_x = c(7, 7, 5, 5, 6.1), 160 | abs_y = c(5, 7, 5, 7, 6.1) 161 | ) 162 | test_data <- data.frame( 163 | index = c(1, 2, 3, 4), 164 | x = c(3, 6, 4, 2), 165 | y = c(2, 1, 4, 2) 166 | ) 167 | # the expected results where calculated using the 168 | # original python-script 169 | exp_frame <- data.frame( 170 | test_data, 171 | abs_x = c(6.02, 7.020099990001998, 4.019800019996, 6.02), 172 | abs_y = c(7.020099990001999, 10.020399960007996, 8.020199980003998, 6.02) 173 | ) 174 | exp_check <- data.frame( 175 | simple_coord, 176 | scalation = c(1.000199980003999, 0.9800000000000004, 1.0199999999999994, 1.000199980003999, Inf), 177 | rotation = c(271.1457628381751, 270.0, 270.0, 268.85423716182487, NaN) 178 | ) 179 | 180 | expect_equal( 181 | cootrans(simple_coord, c(1,2,3,4), test_data, c(2,3), 182 | checkplot = FALSE), 183 | exp_frame 184 | ) 185 | 186 | expect_equal( 187 | cootrans(simple_coord, c(1,2,3,4), test_data, c(2,3), 188 | checking = TRUE, checkplot = FALSE), 189 | exp_check 190 | ) 191 | } 192 | ) -------------------------------------------------------------------------------- /playground/profile/Profile_S.dat: -------------------------------------------------------------------------------- 1 | 1042 1-KS-U X 155081.816 Y 517834.526 Z 81.260 2 | 1043 1-KS-X X 155079.749 Y 517834.587 Z 81.161 3 | 1044 1-KS-Y X 155081.790 Y 517834.465 Z 82.418 4 | 1045 1-GR-Q-S X 155084.100 Y 517834.449 Z 82.422 5 | 1046 1-GR-Q-S X 155084.079 Y 517834.494 Z 81.473 6 | 1047 1-GR-Q-S X 155083.380 Y 517834.512 Z 81.419 7 | 1048 1-GR-Q-S X 155082.567 Y 517834.502 Z 81.373 8 | 1049 1-GR-Q-S X 155081.706 Y 517834.568 Z 81.235 9 | 1050 1-GR-Q-S X 155080.715 Y 517834.574 Z 81.185 10 | 1051 1-GR-Q-S X 155079.784 Y 517834.562 Z 81.168 11 | 1052 1-GR-Q-S X 155079.305 Y 517834.541 Z 81.170 12 | 1053 1-GR-Q-S X 155079.242 Y 517834.503 Z 82.433 13 | 1054 1-GR-Q-S X 155080.110 Y 517834.477 Z 82.459 14 | 1055 1-GR-Q-S X 155080.952 Y 517834.490 Z 82.421 15 | 1056 1-GR-Q-S X 155081.762 Y 517834.475 Z 82.412 16 | 1057 1-GR-Q-S X 155082.548 Y 517834.450 Z 82.429 17 | 1058 1-GR-Q-S X 155083.415 Y 517834.465 Z 82.432 18 | 1059 1-GR-Q-S X 155084.130 Y 517834.454 Z 82.426 19 | 1060 1-FG-Q-S X 155084.043 Y 517834.478 Z 82.351 20 | 1061 1-FG-Q-S X 155084.032 Y 517834.445 Z 81.519 21 | 1062 1-FG-Q-S X 155082.641 Y 517834.466 Z 82.008 22 | 1063 1-FG-Q-S X 155081.461 Y 517834.488 Z 81.245 23 | 1064 1-FG-Q-S X 155081.469 Y 517834.518 Z 82.394 24 | 1065 1-FG-Q-S X 155080.347 Y 517834.521 Z 81.954 25 | 1066 1-FG-Q-S X 155079.340 Y 517834.505 Z 82.376 26 | 1067 1-FG-Q-S X 155079.342 Y 517834.491 Z 81.264 27 | 1068 1-Q-S X 155084.042 Y 517834.511 Z 82.175 28 | 1069 1-Q-S X 155083.498 Y 517834.483 Z 82.152 29 | 1070 1-Q-S X 155082.856 Y 517834.467 Z 82.153 30 | 1071 1-Q-S X 155082.269 Y 517834.476 Z 82.197 31 | 1072 1-Q-S X 155081.683 Y 517834.503 Z 82.188 32 | 1073 1-Q-S X 155081.124 Y 517834.512 Z 82.170 33 | 1074 1-Q-S X 155080.390 Y 517834.514 Z 82.041 34 | 1075 1-Q-S X 155079.880 Y 517834.525 Z 82.073 35 | 1076 1-Q-S X 155079.291 Y 517834.495 Z 82.163 36 | 1077 1-Q-S X 155079.277 Y 517834.489 Z 81.455 37 | 1078 1-Q-S X 155079.819 Y 517834.511 Z 81.511 38 | 1079 1-Q-S X 155080.093 Y 517834.505 Z 81.581 39 | 1080 1-Q-S X 155080.394 Y 517834.494 Z 81.463 40 | 1081 1-Q-S X 155080.592 Y 517834.503 Z 81.597 41 | 1082 1-Q-S X 155080.974 Y 517834.495 Z 81.623 42 | 1083 1-Q-S X 155081.436 Y 517834.490 Z 81.629 43 | 1084 1-Q-S X 155081.884 Y 517834.498 Z 81.631 44 | 1085 1-Q-S X 155082.331 Y 517834.475 Z 81.607 45 | 1086 1-Q-S X 155082.696 Y 517834.468 Z 81.514 46 | 1087 1-Q-S X 155083.099 Y 517834.469 Z 81.619 47 | 1088 1-Q-S X 155083.684 Y 517834.468 Z 81.631 48 | 1089 1-Q-S X 155084.066 Y 517834.445 Z 81.488 49 | 1090 1-HL-Q-S X 155081.396 Y 517834.489 Z 81.314 50 | 1091 1-HL-Q-S X 155080.624 Y 517834.499 Z 81.277 51 | 1092 1-KE-Q-S X 155079.533 Y 517834.508 Z 81.233 52 | 1093 1-KE-Q-S X 155079.381 Y 517834.495 Z 81.311 53 | 1094 1-ST-Q-S X 155083.883 Y 517834.463 Z 81.669 54 | -------------------------------------------------------------------------------- /R/cootrans_func.R: -------------------------------------------------------------------------------- 1 | #' Tool for transforming local metric coordinates 2 | #' 3 | #' This function transforms local metric coordinates to absolute coordinates of referenced 4 | #' systems by use of a two dimensional four parameter Helmert transformation. This function does 5 | #' not cover the transformation of three dimensional points or transformation between two different 6 | #' datums. 7 | #' 8 | #' @param pair_matrix data.frame or matrix with pairs of local and corresponding absolute coordinates (Minimum two!) 9 | #' @param pm_column vector with numerical index of the columns in order: local x-value, local y-value, absolute x-value, absolute y-value 10 | #' @param data_matrix data.frame with local x- and y-values which schould be transformed. 11 | #' @param dm_column vector with numerical index of the columns in order: local x-value, local y-value. 12 | #' @param checking boolean switch to turn on the checking ability. Default: FALSE. If TRUE showes combined coordinate plots with indexed points and alters return of function. 13 | #' @param checkplot boolean switch to turn off the checking plot. Default: TRUE. Only matters if checking == TRUE. 14 | #' 15 | #' @return Original data.frame with additional columns containing the absolute x- and y-coordinates. In case of 'checking = TRUE' returns pair_matrix data.frame with additional columns of scale and rotation arc in degrees. 16 | #' 17 | #' @examples 18 | #' coord_data <- data.frame( 19 | #' loc_x = c(1,3,1,3), 20 | #' loc_y = c(1,1,3,3), 21 | #' abs_x = c(107.1,107,104.9,105), 22 | #' abs_y = c(105.1,107,105.1,106.9) 23 | #' ) 24 | #' 25 | #' data_table <- data.frame( 26 | #' x = c(1.5,1.2,1.6,2), 27 | #' y = c(1,5,2.1,2), 28 | #' type = c("flint","flint","pottery","bone") 29 | #' ) 30 | #' 31 | #' new_frame <- cootrans(coord_data, c(1,2,3,4), data_table, c(1,2)) 32 | #' 33 | #' check_data <- cootrans(coord_data, c(1,2,3,4), data_table, c(1,2), checking = TRUE) 34 | #' 35 | #' @export 36 | #' 37 | 38 | 39 | cootrans <- function( 40 | pair_matrix, 41 | pm_column, 42 | data_matrix, 43 | dm_column, 44 | checking = FALSE, 45 | checkplot = TRUE 46 | ){ 47 | 48 | # 0. initial stuff 49 | # 0.1 define vector calculation function 50 | v_func <- function(x_col, y_col, sp){ 51 | 52 | vec_x <- x_col - sp[1] 53 | vec_y <- y_col - sp[2] 54 | 55 | vec_s <- sqrt(vec_x**2 + vec_y**2) 56 | vec_a <- ifelse(vec_x < 0, -acos(vec_y / vec_s), acos(vec_y / vec_s)) 57 | 58 | returnpackage <- data.frame(m = vec_s, alpha = vec_a) 59 | return(returnpackage) 60 | } 61 | 62 | # 0.2 set column indices 63 | Lx_col <- pm_column[1] 64 | Ly_col <- pm_column[2] 65 | Ax_col <- pm_column[3] 66 | Ay_col <- pm_column[4] 67 | 68 | tx_col <- dm_column[1] 69 | ty_col <- dm_column[2] 70 | 71 | # 1. get helmert parameters 72 | # 1.1 calculate local and absolute centroid 73 | sp_loc <- c(mean(pair_matrix[,Lx_col]), mean(pair_matrix[,Ly_col])) 74 | sp_abs <- c(mean(pair_matrix[,Ax_col]), mean(pair_matrix[,Ay_col])) 75 | 76 | # 1.2 vector attributes 77 | loc_v <- v_func(pair_matrix[,Lx_col], pair_matrix[,Ly_col], sp_loc) 78 | abs_v <- v_func(pair_matrix[,Ax_col], pair_matrix[,Ay_col], sp_abs) 79 | 80 | # 1.3 Scalation 81 | vec_m <- abs_v$m / loc_v$m 82 | sc <- mean(vec_m[is.infinite(vec_m) == FALSE & is.nan(vec_m) == FALSE]) 83 | sc_std <- stats::sd(vec_m[is.infinite(vec_m) == FALSE & is.nan(vec_m) == FALSE]) 84 | 85 | # 1.4 rotation arc 86 | vec_a <- (abs_v$alpha - loc_v$alpha) %% (2*pi) 87 | alpha <- mean(vec_a[is.nan(vec_a) == FALSE]) 88 | alpha_std <- stats::sd(vec_a[is.nan(vec_a) == FALSE]) 89 | 90 | # 1.5 out print for checking transforamtion 91 | message( 92 | paste(c( 93 | "Transformation:", "\n", 94 | "local centroid:", sp_loc, "\n", 95 | "absolute centroid:", sp_abs, "\n", 96 | "scale:", sc, "\n", 97 | "rotation arc:", (alpha*180)/pi 98 | ), collapse = " ") 99 | ) 100 | if ((alpha_std >= 0.1) | (sc_std >= 0.1)){ 101 | warning("High deviations! Some coordinates may be mapped incorrectly.") 102 | } 103 | 104 | # 1.6 special: checking function 105 | if(checking){ 106 | nr <- c(1:length(pair_matrix[,1])) 107 | index <- data.frame( 108 | pair_matrix, 109 | nr 110 | ) 111 | 112 | if(checkplot){ 113 | # change par settings 114 | graphics::par(mfrow = c(1,2)) 115 | 116 | # plot 117 | graphics::plot(index[,Lx_col], index[,Ly_col], 118 | main = "Local coordinates", 119 | xlab = "Local x-value", 120 | ylab = "Local y-value", 121 | cex = 2) 122 | graphics::text(index[,Lx_col], index[,Ly_col], 123 | labels = index$nr, 124 | cex = 0.7) 125 | 126 | graphics::plot(index[,Ax_col],index[,Ay_col], 127 | main = "Absolute coordinates", 128 | xlab = "Absolute x-value", 129 | ylab = "Absolute y-value", 130 | cex = 2) 131 | graphics::text(index[,Ax_col], index[,Ay_col], 132 | labels = index$nr, 133 | cex = 0.7) 134 | 135 | # restore original par settings 136 | graphics::par(mfrow = c(1,1)) 137 | } 138 | 139 | out_frame <- data.frame( 140 | pair_matrix, 141 | scalation = vec_m, 142 | rotation = (vec_a*180/pi) 143 | ) 144 | 145 | } 146 | else{ 147 | 148 | # 2. transformation 149 | # 2.1 vector attributes 150 | vs <- v_func(data_matrix[,tx_col], data_matrix[,ty_col], sp_loc) 151 | # 2.2 calculating new coordinates 152 | Ax <- ifelse(is.nan(vs$alpha), sp_abs[1], sp_abs[1] + sc * vs$m * sin((vs$alpha + alpha))) 153 | Ay <- ifelse(is.nan(vs$alpha), sp_abs[2], sp_abs[2] + sc * vs$m * cos((vs$alpha + alpha))) 154 | 155 | # 3. append data 156 | out_frame <- data.frame(data_matrix, abs_x = Ax, abs_y = Ay) 157 | 158 | } 159 | return(out_frame) 160 | } -------------------------------------------------------------------------------- /vignettes/recexcavAAR-vignette-1.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "recexcavAAR: Vignette >>Semiautomatic spit attribution<<" 3 | author: "Clemens Schmid" 4 | date: "July 2016" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Vignette >>Semiautomatic spit attribution<<} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | ```{r, echo=FALSE} 13 | # check if pandoc is available 14 | if (requireNamespace("rmarkdown") && !rmarkdown::pandoc_available("1.13.1")) 15 | stop("These vignettes assume pandoc version 1.13.1; older versions will not work.") 16 | # see https://r-forge.r-project.org/forum/message.php?msg_id=43797&group_id=234 17 | ``` 18 | 19 | First we need to load recexcavAAR and some external packages: 20 | 21 | - **dplyr:** filter function 22 | - **kriging:** simple surface modelling tool 23 | - **magrittr:** introduces piping via %>% operator 24 | - **rgl:** nice, interactive 3D plots 25 | 26 | ```{r, message=FALSE} 27 | library(devtools) 28 | library(recexcavAAR) 29 | library(dplyr) 30 | library(kriging) 31 | library(magrittr) 32 | library(rgl) 33 | ``` 34 | 35 | Now let's imagine an artificial and pretty simple excavation trench with a depth of 2 meters, a length of 3 meters and a width of 1 meter. 36 | 37 | ```{r} 38 | edges <- data.frame( 39 | x = c(0, 3, 0, 3, 0, 3, 0, 3), 40 | y = c(0, 0, 0, 0, 1, 1, 1, 1), 41 | z = c(0, 0, 2, 2, 0, 0, 2, 2) 42 | ) 43 | ``` 44 | 45 | We can plot the corner points of this trench with `rgl::plot3d`: 46 | 47 | ```{r, echo=FALSE, results="hide"} 48 | # avoid plotting in X11 window 49 | open3d(useNULL = TRUE) 50 | ``` 51 | 52 | ```{r} 53 | plot3d( 54 | edges$x, edges$y, edges$z, 55 | type="s", 56 | aspect = c(3, 1, 2), 57 | xlab = "x", ylab = "y", zlab = "z", 58 | sub = "Grab me and rotate me!" 59 | ) 60 | 61 | bbox3d( 62 | xat = c(0, 1, 2, 3), 63 | yat = c(0, 0.5, 1), 64 | zat = c(0, 0.5, 1, 1.5, 2), 65 | back = "lines" 66 | ) 67 | ``` 68 | 69 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 70 | rglwidget() 71 | ``` 72 | 73 | When we look at the profiles of our fictional trench we can trace three clearly separated horizons following the natural slope. Let's figuratively take some measurements of the two horizon borders by creating two data.frames `df1` and `df2` with points along the profiles. The z axis values are randomly computed. 74 | 75 | ```{r} 76 | df1 <- data.frame( 77 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 78 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 79 | z = c(seq(0.95, 1.2, 0.05), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), seq(0.95, 1.2, 0.05)) 80 | ) 81 | 82 | df2 <- data.frame( 83 | x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 84 | y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 85 | z = c(seq(0.65, 0.9, 0.05), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), seq(0.65, 0.9, 0.05)) 86 | ) 87 | ``` 88 | 89 | Looks complicated? Becomes pretty simple when we look at an other plot. For this one we add the points to the previous plot object by calling `rgl::points3d`. 90 | 91 | ```{r} 92 | points3d( 93 | df1$x, df1$y, df1$z, 94 | col = "darkgreen", 95 | add = TRUE 96 | ) 97 | 98 | points3d( 99 | df2$x, df2$y, df2$z, 100 | col = "blue", 101 | add = TRUE 102 | ) 103 | ``` 104 | 105 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 106 | rglwidget() 107 | ``` 108 | 109 | We can put this two or even more data.frames `df1` and `df2` into a list `lpoints` and feed it to `recexcavAAR::kriglist`. This function serves as an interface to `kriging::kriging`. We'll get a list `maps` of data.frames with surface estimations for the two input layers. 110 | 111 | ```{r } 112 | lpoints <- list(df1, df2) 113 | 114 | maps <- kriglist(lpoints, lags = 3, model = "spherical", pixels = 30) 115 | ``` 116 | 117 | The result of `recexcavAAR::kriging` is in a tall format -- we have to transform it. For this purpose we use `recexcavAAR::spatialwide`. 118 | 119 | ```{r} 120 | surf1 <- spatialwide(maps[[1]]$x, maps[[1]]$y, maps[[1]]$pred, 3) 121 | surf2 <- spatialwide(maps[[2]]$x, maps[[2]]$y, maps[[2]]$pred, 3) 122 | ``` 123 | 124 | After the transformation ``rgl`` can visualize the generated surfaces. 125 | 126 | ```{r} 127 | surface3d( 128 | surf1$x, surf1$y, t(surf1$z), 129 | color = c("black", "white"), 130 | alpha = 0.5, 131 | add = TRUE 132 | ) 133 | 134 | surface3d( 135 | surf2$x, surf2$y, t(surf2$z), 136 | color = c("black", "white"), 137 | alpha = 0.5, 138 | add = TRUE 139 | ) 140 | ``` 141 | 142 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 143 | rglwidget() 144 | ``` 145 | 146 | During the excavation we created an artificial surface every 20 centimeters. Also we seperated the material of 1m\*1m squares. Like this we get bodies of 1m\*1m\*0.2m. Let's set up one by writing the corner coordinates for one into the data.frame `hexatest`: 147 | 148 | ```{r fig.width=7, fig.height=5} 149 | hexatestdf <- data.frame( 150 | x = c(1, 1, 1, 1, 2, 2, 2, 2), 151 | y = c(0, 1, 0, 1, 0, 1, 0, 1), 152 | z = c(0.8, 0.8, 1, 1, 0.8, 0.8, 1, 1) 153 | ) 154 | ``` 155 | 156 | Now we can fill the shape with an equidistant three dimensional point raster using `recexcavAAR::fillhexa` and take a look at it. `recexcavAAR::fillhexa` can deal with completly amorphous hexahedrons. 157 | 158 | ```{r} 159 | cx = fillhexa(hexatestdf, 0.1) 160 | ``` 161 | 162 | ```{r} 163 | completeraster <- points3d( 164 | cx$x, cx$y, cx$z, 165 | col = "red", 166 | add = TRUE 167 | ) 168 | 169 | ``` 170 | 171 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 172 | rglwidget() 173 | 174 | # remove point raster from plot 175 | rgl.pop(id = completeraster) 176 | ``` 177 | 178 | Damn! This spit penetrates both reconstructed surfaces. We should try to determine how his volume is distributed among the three major horizons of our trench. For this purpose we apply `recexcavAAR::posdeclist` (there's also `recexcavAAR::posdec` to apply this to just one data.frame). It makes a position decision for every point of the artificial point raster we created with `recexcavAAR::fillhexa`. 179 | 180 | ```{r} 181 | cuberasterlist <- list(cx) 182 | 183 | crlist <- posdeclist(cuberasterlist, maps) 184 | 185 | hexa <- crlist[[1]] 186 | 187 | a <- filter( 188 | hexa, 189 | pos == 0 190 | ) 191 | 192 | b <- filter( 193 | hexa, 194 | pos == 1 195 | ) 196 | 197 | c <- filter( 198 | hexa, 199 | pos == 2 200 | ) 201 | 202 | points3d( 203 | a$x, a$y, a$z, 204 | col = "red", 205 | add = TRUE 206 | ) 207 | 208 | points3d( 209 | b$x, b$y, b$z, 210 | col = "blue", 211 | add = TRUE 212 | ) 213 | 214 | points3d( 215 | c$x, c$y, c$z, 216 | col = "green", 217 | add = TRUE 218 | ) 219 | ``` 220 | 221 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 222 | rglwidget() 223 | ``` 224 | 225 | Finally we can find out the percentual distribution. Could be an interesting information to determine the possible origin of finds from this spit. 226 | 227 | ```{r} 228 | sapply( 229 | crlist, 230 | function(x){ 231 | x$pos %>% 232 | table() %>% 233 | prop.table() %>% 234 | multiply_by(100) %>% 235 | round(2) 236 | } 237 | ) %>% t 238 | ``` -------------------------------------------------------------------------------- /vignettes/recexcavAAR-vignette-3.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "recexcavAAR: Vignette >>Transforming coordinates<<" 3 | author: "Benjamin Serbe" 4 | date: "January 2017" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Vignette >>Transforming coordinates<<} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | ```{r, echo=FALSE} 13 | # check if pandoc is available 14 | if (requireNamespace("rmarkdown") && !rmarkdown::pandoc_available("1.13.1")) 15 | stop("These vignettes assume pandoc version 1.13.1; older versions will not work.") 16 | # see https://r-forge.r-project.org/forum/message.php?msg_id=43797&group_id=234 17 | ``` 18 | 19 | This vignette gives an overview on the topic of 2D-Coordinate Transforming with the now in recexcevARR implemented *cootrans-*function. 20 | 21 | 22 | ##Background 23 | 24 | In archaeology you often have to deal with data acquired in an era before DGPS and tacheometry became the common surveying method. Even today some excavations use the traditional methods. These data are mostly recorded in local defined grids which are often not suitable for mapping in Geographic Information Systems. The common method to solve that problem is moving and rotating the survey points by hand until they fit the reality. 25 | The *cootrans-*function provides a method to transform a set of local acquired coordinates into projected ones under given circumstances using mathematical calculations. 26 | 27 | 28 | ##Requirements 29 | 30 | This transformation method works only if you have at least two pairs of coordinates of which you know the local and the projected coordinates. Note that these coordinates have to be projected not geographic^1^. 31 | 32 | 33 | ##Limitations 34 | 35 | * This method provides a two-dimensional transformation so only X- and Y-values will be calculated (4-Parameter-Helmert-Transformation). 36 | * This method is **not** suitable for datum transformations (e.g. converting from UTM to national grids). 37 | 38 | 39 | ##Example: A simple transformation 40 | 41 | First load the recexcavARR package: 42 | 43 | ```{r, message=FALSE} 44 | library(recexcavAAR) 45 | ``` 46 | 47 | For this example we use a simple dataset. At first we have the data of the initial surveying with the three major measuring points placed by the surveyor. These are our **projected coordinates** (in this example UTM-coordinates). 48 | 49 | ```{r} 50 | proj <- data.frame( 51 | E = c(578171.033, 578168.680, 578178.780), 52 | N = c(6017854.028, 6017859.595, 6017856.277) 53 | ) 54 | ``` 55 | 56 | After we constructed our own local grid, we add the corresponding local coordinates to the projected ones. 57 | 58 | ```{r} 59 | coord <- data.frame( 60 | proj, 61 | X = c(1, 1, 9), 62 | Y = c(7, 1, 0) 63 | ) 64 | ``` 65 | This is the data table we need to successfully perform a transformation for all local coordinates we acquire throughout the excavation. 66 | 67 | Now we add some data e.g. the corners of our excavation trench or the artifacts we excavated. 68 | 69 | ```{r} 70 | measured_points <- data.frame( 71 | x = c(1,6,1,6), 72 | Y = c(3,3,5,5), 73 | point = c("corner1", "corner2", "corner3", "corner4") 74 | ) 75 | ``` 76 | 77 | And now let's use the *cootrans-*function to calculate the UTM-coordinates of our trench corners. 78 | 79 | ```{r} 80 | absolute_data <- cootrans(coord, c(3,4,1,2), measured_points, c(1,2)) 81 | ``` 82 | The first parameter in this function is our data.frame for the transformation. The directional shifts, rotation arcs and the scale will be calculated from these information. 83 | The second parameter is a vector of the column indices of our transformation table in the specific order: 84 | 85 | 1. the local x-value (east-value) 86 | 87 | 2. the local y-value (north-value) 88 | 89 | 3. the projected x-value (east-value) 90 | 91 | 4. the projected y-value (north-value) 92 | 93 | The third parameter is the data.frame with our measured local coordinates which should be transformed. 94 | Our last parameter is a vector of the column indices of our dataset in order: 95 | 96 | 1. the local x-value (east-value) 97 | 98 | 2. the local y-value (north-value) 99 | 100 | 101 | 102 | The *cootrans-*function returns the original data.frame with two additional columns with the calculated projected coordinates and shows information about the transformation. 103 | 104 | 105 | In this case we get an addtional warning message of high deviations within the calculation. The most likely mistake is the incorrect assignement of local and corresponding projected coordinates. This does not have to be the reason for the triggered warning message because the internal control mechanism is rather strict. But to check the case of incorrectly defined points we can use the additional parameter "checking" which is set `FALSE` by default. 106 | 107 | ```{r, message=FALSE, fig.width=7, fig.height=5} 108 | check_data <- cootrans(coord, c(3,4,1,2), measured_points, c(1,2), checking = TRUE) 109 | ``` 110 | 111 | In this case the function will display a combined plot with the mapped local and projected coordinates. Every survey point is labled with an index number of their row. 112 | Addtionally the function now returns our transformation table with the calculated scales and roation arcs (in degrees) for each pair of coordinates. 113 | 114 | ```{r} 115 | check_data 116 | ``` 117 | 118 | If we display our `check_data`, we will notice the scale of pair three seems fine. In both (local and absolute) grids, we use metres as units, so the scale schould be around `1`. The scale of point one and two do not match this assumption, also the rotations arcs differ too much. 119 | The displayed plots and the `check_data` show that the local points with the indices 1 and 2 are not corresponding with the projected ones. So they are likely mixed up. In this case we simply rebuild the transformation data.frame: 120 | 121 | ```{r} 122 | corr_coord <- data.frame( 123 | proj, 124 | X = c(1, 1, 9), 125 | Y = c(1, 7, 0) 126 | ) 127 | ``` 128 | As shown we only interchanged the Y-value of the first and second coordinate. Now we run the *cootrans*-function for the second time and check our transformation: 129 | ```{r, fig.width=7, fig.height=5} 130 | check_data <- cootrans(corr_coord, c(3,4,1,2), measured_points, c(1,2), checking = TRUE) 131 | ``` 132 | 133 | And everything seems fine. No warning message pops up and the `check_data` show all scales and rotaions arcs around the same values. 134 | So now let's use the *cootrans*-function one last time to get our absolute data for the excavation trench corners. 135 | 136 | ```{r} 137 | absolute_data <- cootrans(corr_coord, c(3,4,1,2), measured_points, c(1,2)) 138 | ``` 139 | 140 | At this point we can proceed with further analyses of our now georeferenced spatial data. 141 | 142 | *** 143 | **Attention!** 144 | The warning message and checking parameter only work reasonable if there are **more than two** given coordinate pairs. In case of only two points and incorrect defined coordinates the algorithm will just turn all of the measured points by 180°. So always check your output! 145 | 146 | *** 147 | ^1^ For those who are not familiar with these terms: projected coordinates use a grid system such as UTM. Geographic coordinates are e.g. "lon-lat"-coordinates. 148 | 149 | -------------------------------------------------------------------------------- /src/drawing_functions.cpp: -------------------------------------------------------------------------------- 1 | #define _USE_MATH_DEFINES 2 | 3 | #include 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | //' Draws a circular point cloud (3D) 9 | //' 10 | //' @description 11 | //' Draws a 2D circle on x- and y-plane around a center point in 3D space. 12 | //' 13 | //' @param centerx x axis value of circle center point 14 | //' @param centery y axis value of circle center point 15 | //' @param centerz z axis value of circle center point 16 | //' @param radius circle radius 17 | //' @param resolution amount of circle points (default = 30) 18 | //' 19 | //' @return 20 | //' data.frame with the spatial coordinates of the resulting points 21 | //' 22 | //' @examples 23 | //' draw_circle( 24 | //' centerx = 4, 25 | //' centery = 5, 26 | //' centerz = 1, 27 | //' radius = 3, 28 | //' resolution = 20 29 | //' ) 30 | //' 31 | //' circ <- draw_circle(1,2,3,2) 32 | //' 33 | //' plot(circ$x, circ$y) 34 | //' 35 | //' @export 36 | // [[Rcpp::export]] 37 | DataFrame draw_circle(double centerx, double centery, double centerz, double radius, int resolution = 30) { 38 | 39 | int pnum = resolution; 40 | double rotation = 2 * M_PI / pnum; 41 | NumericMatrix res(pnum, 3); 42 | 43 | for (int p1 = 0; p1 < pnum; p1++) { 44 | double rot = p1 * rotation; 45 | res(p1, 0) = centerx + cos(rot) * radius; 46 | res(p1, 1) = centery + sin(rot) * radius; 47 | res(p1, 2) = centerz; 48 | } 49 | 50 | // output 51 | return DataFrame::create(_["x"] = res(_,0), _["y"] = res(_,1), _["z"] = res(_,2)); 52 | } 53 | 54 | //' Rotate a point cloud around a pivot point (3D) 55 | //' 56 | //' @description 57 | //' Rotate a point cloud around a defined pivot point by defined angles. The default 58 | //' rotation angle around each axis is zero and the default pivot point is the center 59 | //' point of the point cloud (defined by mean()) 60 | //' 61 | //' @param x vector of x axis values of rotation point cloud 62 | //' @param y vector of y axis values of rotation point cloud 63 | //' @param z vector of z axis values of rotation point cloud 64 | //' @param degrx rotation angle around x axis in degree (default = 0) 65 | //' @param degry rotation angle around y axis in degree (default = 0) 66 | //' @param degrz rotation angle around z axis in degree (default = 0) 67 | //' @param pivotx x axis value of pivot point (default = mean(x)) 68 | //' @param pivoty y axis value of pivot point (default = mean(y)) 69 | //' @param pivotz z axis value of pivot point (default = mean(z)) 70 | //' 71 | //' @return 72 | //' data.frame with the spatial coordinates of the resulting points 73 | //' 74 | //' @examples 75 | //' circ <- draw_circle(0,0,0,5) 76 | //' 77 | //' #library(rgl) 78 | //' #plot3d( 79 | //' # circ, 80 | //' # xlim = c(-6,6), 81 | //' # ylim = c(-6,6), 82 | //' # zlim = c(-6,6) 83 | //' #) 84 | //' 85 | //' rotcirc <- rotate(circ$x, circ$y, circ$z, degrx = 45) 86 | //' 87 | //' #plot3d( 88 | //' # rotcirc, 89 | //' # xlim = c(-6,6), 90 | //' # ylim = c(-6,6), 91 | //' # zlim = c(-6,6) 92 | //' #) 93 | //' 94 | //' @export 95 | // [[Rcpp::export]] 96 | DataFrame rotate(NumericVector x, NumericVector y, NumericVector z, 97 | double degrx = 0.0, double degry = 0.0, double degrz = 0.0, 98 | double pivotx = NA_REAL, double pivoty = NA_REAL, double pivotz = NA_REAL) { 99 | 100 | // check for pivot point values 101 | // (ugly hack to use is_na) 102 | NumericVector pivot = NumericVector::create(pivotx, pivoty, pivotz); 103 | if (NumericVector::is_na(pivot(0))) { pivotx = mean(x); } 104 | if (NumericVector::is_na(pivot(1))) { pivoty = mean(y); } 105 | if (NumericVector::is_na(pivot(2))) { pivotz = mean(z); } 106 | 107 | int num = x.length(); 108 | 109 | double radx = (degrx*M_PI)/180; 110 | double rady = (degry*M_PI)/180; 111 | double radz = (degrz*M_PI)/180; 112 | 113 | NumericMatrix res(num, 3); 114 | 115 | for (int p1 = 0; p1 < num; p1++) { 116 | 117 | // move 118 | double xi = x(p1) - pivotx; 119 | double yi = y(p1) - pivoty; 120 | double zi = z(p1) - pivotz; 121 | 122 | // rotation along z 123 | double xii = xi * cos(radz) - yi * sin(radz); 124 | double yii = xi * sin(radz) + yi * cos(radz); 125 | double zii = zi; 126 | 127 | // rotation along y 128 | double xiii = xii * cos(rady) - zii * sin(rady); 129 | double yiii = yii; 130 | double ziii = xii * sin(rady) + zii * cos(rady); 131 | 132 | // rotation along x 133 | double xiiii = xiii; 134 | double yiiii = yiii * cos(radx) - ziii * sin(radx); 135 | double ziiii = yiii * sin(radx) + ziii * cos(radx); 136 | 137 | res(p1, 0) = xiiii + pivotx; 138 | res(p1, 1) = yiiii + pivoty; 139 | res(p1, 2) = ziiii + pivotz; 140 | 141 | } 142 | 143 | // output 144 | return DataFrame::create(_["x"] = res(_,0), _["y"] = res(_,1), _["z"] = res(_,2)); 145 | } 146 | 147 | //' Draws a spherical point cloud (3D) 148 | //' 149 | //' @description 150 | //' Draws a sphere around a center point in 3D space. 151 | //' 152 | //' @param centerx x axis value of sphere center point 153 | //' @param centery y axis value of sphere center point 154 | //' @param centerz z axis value of sphere center point 155 | //' @param radius sphere radius 156 | //' @param phires phi resolution (default = 10) 157 | //' @param thetares theta resolution (default = 10) 158 | //' 159 | //' @return 160 | //' data.frame with the spatial coordinates of the resulting points 161 | //' 162 | //' @examples 163 | //' sphere <- draw_sphere( 164 | //' centerx = 4, 165 | //' centery = 5, 166 | //' centerz = 1, 167 | //' radius = 3, 168 | //' phires = 20, 169 | //' thetares = 20 170 | //' ) 171 | //' 172 | //' #library(rgl) 173 | //' #plot3d(sphere) 174 | //' 175 | //' @export 176 | // [[Rcpp::export]] 177 | DataFrame draw_sphere(double centerx, double centery, double centerz, 178 | double radius, int phires = 10, int thetares = 10) { 179 | 180 | double phir = (double) phires; 181 | double thetar = (double) thetares; 182 | 183 | std::vector x; 184 | std::vector y; 185 | std::vector z; 186 | 187 | // Iterate through phi and theta 188 | for (double phi = 0.; phi < 2 * M_PI; phi += M_PI / phir) { // Azimuth [0, 2M_PI] 189 | for (double theta = 0.; theta < M_PI; theta += M_PI / thetar) { // Elevation [0, M_PI] 190 | 191 | x.push_back(radius * cos(phi) * sin(theta) + centerx); 192 | y.push_back(radius * sin(phi) * sin(theta) + centery); 193 | z.push_back(radius * cos(theta) + centerz); 194 | 195 | } 196 | } 197 | 198 | // output 199 | return DataFrame::create(_["x"] = wrap(x), _["y"] = wrap(y), _["z"] = wrap(z)); 200 | } 201 | 202 | //' Scales a point cloud (3D) 203 | //' 204 | //' @description 205 | //' Scales a 3D point cloud on every axis. 206 | //' 207 | //' @param x vector of x axis values of scale point cloud 208 | //' @param y vector of y axis values of scale point cloud 209 | //' @param z vector of z axis values of scale point cloud 210 | //' @param scalex scaling factor on x axis (default = 1) 211 | //' @param scaley scaling factor on y axis (default = 1) 212 | //' @param scalez scaling factor on z axis (default = 1) 213 | //' 214 | //' @return 215 | //' data.frame with the spatial coordinates of the resulting points 216 | //' 217 | //' @examples 218 | //' s <- draw_sphere(1,1,1,3) 219 | //' 220 | //' #library(rgl) 221 | //' #plot3d(s) 222 | //' 223 | //' s2 <- rescale(s$x, s$y, s$z, scalex = 4, scalez = 5) 224 | //' 225 | //' #library(rgl) 226 | //' #plot3d(s2) 227 | //' 228 | //' @export 229 | // [[Rcpp::export]] 230 | DataFrame rescale(NumericVector x, NumericVector y, NumericVector z, 231 | double scalex = 1, double scaley = 1, double scalez = 1) { 232 | 233 | NumericMatrix res(x.size(), 3); 234 | 235 | res(_, 0) = x * scalex; 236 | res(_, 1) = y * scaley; 237 | res(_, 2) = z * scalez; 238 | 239 | // output 240 | return DataFrame::create(_["x"] = res(_, 0), _["y"] = res(_, 1), _["z"] = res(_ ,2)); 241 | } -------------------------------------------------------------------------------- /src/posdecis.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "helpfunc.h" 6 | 7 | using namespace Rcpp; 8 | 9 | //' Multiple point position decision in relation to a set of stacked surfaces (3D) 10 | //' 11 | //' \code{posdec} has the purpose to make a decision about the position of individual points in relation 12 | //' to a set of stacked surfaces in 3D space. The decision is made by comparing the mean z axis value of 13 | //' the four horizontally closest points of a surface to the z axis value of the point in question. 14 | //' 15 | //' @param crdf data.frame with the spatial coordinates of the points of interest. Must contain three 16 | //' columns with the x axis values, y axis values and z axis values of the points in the order x, y, z 17 | //' @param maplist list of data.frames which contain the points that make up the surfaces. The individual 18 | //' data.frames must have the same structure as \code{crdf} 19 | //' 20 | //' @return data.frame with the spatial coordinates of the points of interest and the respective position 21 | //' information 22 | //' 23 | //' @family posdecfuncs 24 | //' 25 | //' @examples 26 | //' df1 <- data.frame( 27 | //' x = rnorm(50), 28 | //' y = rnorm(50), 29 | //' z = rnorm(50) - 5 30 | //' ) 31 | //' 32 | //' df2 <- data.frame( 33 | //' x = rnorm(50), 34 | //' y = rnorm(50), 35 | //' z = rnorm(50) + 5 36 | //') 37 | //' 38 | //' lpoints <- list(df1, df2) 39 | //' 40 | //' maps <- kriglist(lpoints, lags = 3, model = "spherical") 41 | //' 42 | //' finds <- data.frame( 43 | //' x = c(0, 1, 0.5, 0.7), 44 | //' y = c(0.5, 0, 1, 0.7), 45 | //' z = c(-10, 10, 0, 2) 46 | //' ) 47 | //' 48 | //' posdec(finds, maps) 49 | //' 50 | //' @export 51 | // [[Rcpp::export]] 52 | DataFrame posdec(DataFrame crdf, List maplist){ 53 | 54 | Function asMatrix("as.matrix"); 55 | 56 | // transform input pointlist to NumericMatrix -> cube2 57 | SEXP cube2mid = crdf; 58 | NumericMatrix cube2 = asMatrix(cube2mid); 59 | // create result table with decision column -> cubedec 60 | NumericMatrix cubedec(cube2.nrow(), 4); 61 | // loop to deal with every layer 62 | for (int mp = 0; mp < maplist.size(); mp++) { 63 | // select matrix with points of the current layer -> curmap 64 | SEXP curmapmid = maplist[mp]; 65 | NumericMatrix curmap = asMatrix(curmapmid); 66 | // find maxdist of current layer (puspose: see below) 67 | NumericVector xcl = curmap(_, 0); 68 | NumericVector ycl = curmap(_, 1); 69 | double maxdist = pyth(minv(xcl), minv(ycl), maxv(xcl), maxv(ycl)); 70 | // create vectors for individual point distances 71 | // (horizontal -> mindistps and vertical -> mindistz) 72 | NumericVector mindistps(4); 73 | NumericVector mindistz(4); 74 | // loop to deal with every single point of interest 75 | for (int pcube = 0; pcube < cube2.nrow(); pcube++) { 76 | // get horizontal coordinates of the single point of interest -> x1, y1 77 | double x1 = cube2(pcube, 0); 78 | double y1 = cube2(pcube, 1); 79 | // loop to determine four points with the shortest distance by calculating distance of single point 80 | // to every point of the current layer 81 | for (int p1 = 0; p1 < curmap.nrow(); p1++) { 82 | // get horizontal coordinates of the single point of the layer -> x2, y2 83 | double x2 = curmap(p1, 0); 84 | double y2 = curmap(p1, 1); 85 | // calculate horizontal euclidian distance of single point of interest and single point of layer 86 | // -> dist 87 | double dist = pyth(x1, y1, x2, y2); 88 | // at the beginning: set minimum distance value for all four closest points to maxdist - this value 89 | // will be adjusted step by step 90 | if (p1 == 0) { 91 | mindistps(0) = maxdist; 92 | mindistps(1) = maxdist; 93 | mindistps(2) = maxdist; 94 | mindistps(3) = maxdist; 95 | } 96 | //debug 97 | // if (p1 % 100 == 0) { 98 | // Rcout << "layer: " << mp << std::endl; 99 | // Rcout << "0 " << mindistps(0) << std::endl; 100 | // Rcout << "1 " << mindistps(1) << std::endl; 101 | // Rcout << "2 " << mindistps(2) << std::endl; 102 | // Rcout << "3 " << mindistps(3) << std::endl; 103 | // if (mp >= 3) { 104 | // Rcout << "x2 - " << x2 << std::endl; 105 | // Rcout << "y2 - " << y2 << std::endl; 106 | // Rcout << "dist - " << dist << std::endl; 107 | // } 108 | // } 109 | // find id of biggest value in vector mindistps 110 | int id = maxid(mindistps); 111 | // if the current point of layer has a smaller distance to the current point of interest, then 112 | // replace the biggest value in vector mindistps by new smaller value (if so) and also store z value 113 | // of the current single point of layer 114 | if (dist <= mindistps(id)) { 115 | mindistps(id) = dist; 116 | mindistz(id) = curmap(p1, 2); 117 | } 118 | } 119 | // calculate mean height (-> zmap) of the four horizontally closest points of layer stored in vectors 120 | // mindistps and mindistz 121 | double ztemp = 0; 122 | for (int p3 = 0; p3 < mindistz.size(); p3++) { 123 | ztemp += mindistz(p3); 124 | } 125 | double zmap = ztemp/4.0; 126 | // copy coordinate values of current points from input point list to output point list 127 | cubedec(pcube, 0) = cube2(pcube, 0); 128 | cubedec(pcube, 1) = cube2(pcube, 1); 129 | cubedec(pcube, 2) = cube2(pcube, 2); 130 | // 131 | if (mp == 0 && cube2(pcube, 2) >= zmap) { 132 | cubedec(pcube, 3) = mp+1; 133 | } else if (mp != 0 && cube2(pcube, 2) >= zmap) { 134 | cubedec(pcube, 3) += 1; 135 | } 136 | 137 | //debug 138 | //break; 139 | 140 | } 141 | } 142 | 143 | // copying columns of cubedec (output list) to individual NumericVectors to be able to construct a nice 144 | // output data.frame 145 | NumericVector x = cubedec(_,0); 146 | NumericVector y = cubedec(_,1); 147 | NumericVector z = cubedec(_,2); 148 | NumericVector pos = cubedec(_,3); 149 | 150 | // construct output data.frame, then output 151 | return DataFrame::create(_["x"] = x, _["y"] = y, _["z"] = z, _["pos"] = pos); 152 | } 153 | 154 | //' Multiple point position decision in relation to a set of stacked surfaces (3D) 155 | //' for multiple data.frames in a list 156 | //' 157 | //' \code{posdeclist} works as \code{\link{posdec}} but not just for a single data.frame 158 | //' with individual points but for a list of data.frames 159 | //' 160 | //' @param crdflist list of data.frames with the spatial coordinates of the points of 161 | //' interest (for details see \code{\link{posdec}}) 162 | //' @param maplist list of data.frames which contain the points that make up the surfaces 163 | //' 164 | //' @return list of data.frames with the spatial coordinates of the points of interest 165 | //' and the respective position information 166 | //' 167 | //' @family posdecfuncs 168 | //' 169 | //' @examples 170 | //' df1 <- data.frame( 171 | //' x = rnorm(50), 172 | //' y = rnorm(50), 173 | //' z = rnorm(50) - 5 174 | //' ) 175 | //' 176 | //' df2 <- data.frame( 177 | //' x = rnorm(50), 178 | //' y = rnorm(50), 179 | //' z = rnorm(50) + 5 180 | //') 181 | //' 182 | //' lpoints <- list(df1, df2) 183 | //' 184 | //' maps <- kriglist(lpoints, lags = 3, model = "spherical") 185 | //' 186 | //' hexadf1 <- data.frame( 187 | //' x = c(0, 1, 0, 4, 5, 5, 5, 5), 188 | //' y = c(1, 1, 4, 4, 1, 1, 4, 4), 189 | //' z = c(1, 5, 1, 6, 1, 5, 1, 3) 190 | //' ) 191 | //' 192 | //' hexadf2 <- data.frame( 193 | //' x = c(0, 1, 0, 4, 5, 5, 5, 5), 194 | //' y = c(1, 1, 4, 4, 1, 1, 4, 4), 195 | //' z = c(-1, -5, -1, -6, -1, -5, -1, -3) 196 | //' ) 197 | //' 198 | //' cx1 <- fillhexa(hexadf1, 0.1) 199 | //' cx2 <- fillhexa(hexadf2, 0.1) 200 | //' 201 | //' cubelist <- list(cx1, cx2) 202 | //' 203 | //' posdeclist(cubelist, maps) 204 | //' 205 | //' @export 206 | // [[Rcpp::export]] 207 | List posdeclist(List crdflist, List maplist){ 208 | 209 | for (int crp = 0; crp < crdflist.size(); crp++){ 210 | 211 | SEXP curcrdflist = crdflist[crp]; 212 | crdflist[crp] = posdec(curcrdflist, maplist); 213 | 214 | } 215 | 216 | return crdflist; 217 | } -------------------------------------------------------------------------------- /vignettes/recexcavAAR-vignette-2.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "recexcavAAR: Vignette >>Trench visualisation<<" 3 | author: "Clemens Schmid" 4 | date: "August 2016" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Vignette >>Trench visualisation<<} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | ```{r, echo=FALSE} 13 | # check if pandoc is available 14 | if (requireNamespace("rmarkdown") && !rmarkdown::pandoc_available("1.13.1")) 15 | stop("These vignettes assume pandoc version 1.13.1; older versions will not work.") 16 | # see https://r-forge.r-project.org/forum/message.php?msg_id=43797&group_id=234 17 | ``` 18 | 19 | First we need to load recexcavAAR and some external packages: 20 | 21 | - **kriging:** simple surface modelling tool 22 | - **rgl:** nice, interactive 3D plots 23 | 24 | ```{r, message=FALSE} 25 | library(devtools) 26 | library(recexcavAAR) 27 | library(kriging) 28 | library(rgl) 29 | ``` 30 | 31 | Like in the first vignette `Ifri el Baroud` we start by setting up an artificial and pretty simple excavation trench with a depth of 1.4 meters, a length of 6 meters and a width of 8 meters. This one is not parallel to the main axis of our coordinate system. 32 | 33 | ```{r} 34 | edges <- data.frame( 35 | x = c(6.899, 10.658, 4.428, 0.669, 6.899, 10.658, 4.428, 0.669), 36 | y = c(19.292, 14.616, 9.597, 14.273, 19.292, 14.616, 9.597, 14.273), 37 | z = c(9.7, 9.7, 9.7, 9.7, 8.3, 8.3, 8.3, 8.3) 38 | ) 39 | ``` 40 | 41 | We can plot the edges of this trench with `rgl::plot3d`, but first of all we have to calculate a reasonable aspectratio. Remember: The trench is tilted in relation to the main axis. 42 | 43 | ```{r} 44 | rangex <- abs(max(edges$x) - min(edges$x)) 45 | rangey <- abs(max(edges$y) - min(edges$y)) 46 | 47 | edgesordered = rbind( 48 | edges[1:4, ], 49 | edges[1, ], 50 | edges[5:8, ], 51 | edges[5, ], 52 | edges[c(6,2), ], 53 | edges[c(3,7), ], 54 | edges[c(8,4), ] 55 | ) 56 | ``` 57 | 58 | ```{r, echo=FALSE, results="hide"} 59 | # avoid plotting in X11 window 60 | open3d(useNULL = TRUE) 61 | ``` 62 | 63 | ```{r} 64 | plot3d( 65 | edgesordered$x, edgesordered$y, edgesordered$z, 66 | type="l", 67 | aspect = c(rangex, rangey, 5), 68 | xlab = "x", ylab = "y", zlab = "z", 69 | sub = "Grab me and rotate me!", 70 | col = "darkgreen" 71 | ) 72 | 73 | bbox3d( 74 | xat = c(2, 4, 6, 8, 10), 75 | yat = c(10, 12, 14, 16, 18), 76 | zat = c(8.5, 9, 9.5), 77 | back = "lines" 78 | ) 79 | ``` 80 | 81 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 82 | rglwidget() 83 | ``` 84 | 85 | The approach for the excavation of this trench is to go deeper in squares of 1 meter by 1 meter. The spit depth is about 30 centimeters, but as we also try to follow natural layers the individual spit depth varies a lot. Fortunately we have niveau measurements of the resulting surfaces in the dataset `recexcavAAR::KT_spits`. 86 | 87 | ```{r} 88 | sp <- KT_spits 89 | 90 | splist <- list() 91 | spitnames <- c("^surface", "^spit1", "^spit2", "^spit3", "^bottom") 92 | 93 | for (i in 1:length(spitnames)){ 94 | splist[[i]] <- sp[grep(spitnames[i], sp$id), ] 95 | } 96 | ``` 97 | 98 | Let's apply kriging with `recexcavAAR::kriglist`, transform the result with `recexcavAAR::spatialwide` and add the surfaces to the plot. 99 | 100 | ```{r} 101 | # I had to choose a very low pixel value to keep the vignette small enough 102 | maps <- kriglist(splist, x = 2, y = 3, z = 4, lags = 3, model = "spherical", pixels = 30) 103 | 104 | surf <- list() 105 | for (i in 1:length(maps)) { 106 | surf[[i]] <- spatialwide(maps[[i]]$x, maps[[i]]$y, maps[[i]]$pred, digits = 3) 107 | } 108 | 109 | idvec <- c() 110 | for (i in 1:length(surf)) { 111 | idvec[i] <- surface3d( 112 | surf[[i]]$x, surf[[i]]$y, t(surf[[i]]$z), 113 | color = c("black", "white"), 114 | alpha = 0.5, 115 | add = TRUE 116 | ) 117 | } 118 | ``` 119 | 120 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 121 | rglwidget() 122 | ``` 123 | 124 | ```{r} 125 | # remove surfaces from plot 126 | for (i in 1:length(idvec)) { 127 | rgl.pop(id = idvec[i]) 128 | } 129 | ``` 130 | 131 | Hm... ok. But the surfaces extend beyond the surfaces of the trench... We can use `recexcavAAR::pnpmulti` to decide which points of the kriging result are within the trench polygon. Then we can remove the others and plot the result again. 132 | 133 | ```{r} 134 | for (i in 1:length(maps)) { 135 | rem <- recexcavAAR::pnpmulti(edges$x[1:4], edges$y[1:4], maps[[i]]$x, maps[[i]]$y) 136 | maps[[i]] <- maps[[i]][rem, ] 137 | } 138 | 139 | surf2 <- list() 140 | for (i in 1:length(maps)) { 141 | surf2[[i]] <- recexcavAAR::spatialwide(maps[[i]]$x, maps[[i]]$y, maps[[i]]$pred, 3) 142 | } 143 | 144 | for (i in 1:length(surf)) { 145 | surface3d( 146 | surf2[[i]]$x, surf2[[i]]$y, t(surf2[[i]]$z), 147 | color = c("black", "white"), 148 | alpha = 0.5, 149 | add = TRUE 150 | ) 151 | } 152 | ``` 153 | 154 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 155 | rglwidget() 156 | ``` 157 | 158 | Now to the actual task: During the excavation we found a lot of pottery from all over the trench. Many of the individual sherds fit together -- it's possible to reconstruct complete vessels. We would like to visualize how the sherds of one particular vessel are distributed. The spatial information for this vessel is stored in the dataset `recexcavAAR::vessel`. 159 | 160 | Some of the sherds were considered special during the excavation and were therefore measured individualy (Inventar Number *"KTF_..."*). 161 | 162 | ```{r} 163 | ve <- KT_vessel 164 | vesselsingle <- ve[grep("KTF", ve$inv), ] 165 | 166 | points3d( 167 | vesselsingle$x, vesselsingle$y, vesselsingle$z, 168 | col = "red", 169 | size = 8, 170 | add = TRUE 171 | ) 172 | ``` 173 | 174 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 175 | rglwidget() 176 | ``` 177 | 178 | Unfortunately many were not. For these we just have the information from which spit and square they are coming from (Inv. Nr. *"KTM_..."*). 179 | 180 | ```{r} 181 | vesselmass <- ve[grep("KTM", ve$inv), ] 182 | ``` 183 | 184 | To visualize their position in the trench we could maybe set a point to the center of the respective square. The horizontal center of the square is easy to determine - but due to the irregular way of excavation which respects natural layers it's much more complex to get the vertical center of the square. 185 | 186 | Let's first of all load the dataset `recexcavAAR::KT_squarecorners` with the square point raster and create a list with the 4 individual corner points of each square. 187 | 188 | ```{r} 189 | sqc <- KT_squarecorners 190 | 191 | squares <- list() 192 | sqnum <- 1 193 | for (i in 1:(nrow(sqc) - 9)) { 194 | if (i %% 9 == 0) { 195 | next 196 | } else { 197 | a <- sqc[i, ] 198 | b <- sqc[i + 1, ] 199 | c <- sqc[i + 9, ] 200 | d <- sqc[i + 10, ] 201 | } 202 | squares[[sqnum]] <- data.frame( 203 | x = c(a[, 1], b[, 1], c[, 1], d[, 1]), 204 | y = c(a[, 2], b[, 2], c[, 2], d[, 2]) 205 | ) 206 | sqnum <- sqnum + 1 207 | } 208 | ``` 209 | 210 | Now we can use `recexcavAAR::spitcenternatlist` to determine the list of spit center points in relation to the defined documentation surfaces. 211 | 212 | ```{r} 213 | sqcenters <- recexcavAAR::spitcenternatlist(squares, maps) 214 | 215 | for (i in 1:length(sqcenters)) { 216 | sqcenters[[i]] <- data.frame(sqcenters[[i]], square = i, spit = c("spit1", "spit2", "spit3", "bottom")) 217 | } 218 | 219 | sqcdf <- do.call(rbind.data.frame, sqcenters) 220 | ``` 221 | 222 | Let's plot all of them for once. 223 | 224 | ```{r} 225 | completeraster <- points3d( 226 | sqcdf$x, sqcdf$y, sqcdf$z, 227 | col = "darkgreen", 228 | add = TRUE 229 | ) 230 | ``` 231 | 232 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 233 | rglwidget() 234 | ``` 235 | 236 | ```{r} 237 | # remove point raster from plot 238 | rgl.pop(id = completeraster) 239 | ``` 240 | 241 | Finally we can merge the info about the vessel sherds in `vesselmass` with the new list of square center points `sqcdf`. Now we can plot single find sherds and mass find sherds together. 242 | 243 | ```{r warning=FALSE} 244 | vmsq <- merge(vesselmass[, 1:4], sqcdf, by = c("square", "spit"), all.x = TRUE) 245 | 246 | vesselm <- vmsq[complete.cases(vmsq), ] 247 | 248 | points3d( 249 | vesselm$x, vesselm$y, vesselm$z, 250 | col = "orange", 251 | size = 8, 252 | add = TRUE 253 | ) 254 | ``` 255 | 256 | ```{r, echo=FALSE, fig.width=7, fig.height=5} 257 | rglwidget() 258 | ``` -------------------------------------------------------------------------------- /playground/profile/Profile_NW3.dat: -------------------------------------------------------------------------------- 1 | 3746 1-KS-U X 155052.253 Y 517836.615 Z 80.566 2 | 3747 1-KS-X X 155059.088 Y 517843.430 Z 80.586 3 | 3748 1-KS-Y X 155052.170 Y 517836.774 Z 81.886 4 | 3749 1-GR-R-NW3 X 155049.478 Y 517833.924 Z 81.120 5 | 3750 1-GR-R-NW3 X 155049.941 Y 517834.415 Z 81.072 6 | 3751 1-GR-R-NW3 X 155050.527 Y 517834.982 Z 81.009 7 | 3752 1-GR-R-NW3 X 155051.191 Y 517835.623 Z 80.923 8 | 3753 1-GR-R-NW3 X 155051.505 Y 517835.903 Z 80.904 9 | 3754 1-GR-R-NW3 X 155052.218 Y 517836.575 Z 80.578 10 | 3755 1-GR-R-NW3 X 155053.102 Y 517837.536 Z 80.520 11 | 3756 1-GR-R-NW3 X 155053.896 Y 517838.318 Z 80.533 12 | 3757 1-GR-R-NW3 X 155054.632 Y 517839.031 Z 80.509 13 | 3758 1-GR-R-NW3 X 155055.350 Y 517839.740 Z 80.470 14 | 3759 1-GR-R-NW3 X 155056.251 Y 517840.608 Z 80.500 15 | 3760 1-GR-R-NW3 X 155056.347 Y 517840.685 Z 80.389 16 | 3761 1-GR-R-NW3 X 155056.619 Y 517840.940 Z 80.409 17 | 3762 1-GR-R-NW3 X 155056.699 Y 517841.052 Z 80.519 18 | 3763 1-GR-R-NW3 X 155056.879 Y 517841.225 Z 80.487 19 | 3764 1-GR-R-NW3 X 155056.929 Y 517841.260 Z 80.098 20 | 3765 1-GR-R-NW3 X 155057.942 Y 517842.273 Z 80.090 21 | 3766 1-GR-R-NW3 X 155059.033 Y 517843.305 Z 80.199 22 | 3767 1-GR-R-NW3 X 155059.018 Y 517843.367 Z 80.570 23 | 3768 1-GR-R-NW3 X 155059.590 Y 517843.930 Z 80.736 24 | 3769 1-GR-R-NW3 X 155060.153 Y 517844.469 Z 80.834 25 | 3770 1-GR-R-NW3 X 155059.900 Y 517844.509 Z 82.169 26 | 3771 1-GR-R-NW3 X 155059.095 Y 517843.691 Z 82.141 27 | 3772 1-GR-R-NW3 X 155057.986 Y 517842.613 Z 82.051 28 | 3773 1-GR-R-NW3 X 155057.031 Y 517841.598 Z 82.039 29 | 3774 1-GR-R-NW3 X 155056.130 Y 517840.676 Z 81.975 30 | 3775 1-GR-R-NW3 X 155055.113 Y 517839.706 Z 81.901 31 | 3776 1-GR-R-NW3 X 155053.839 Y 517838.443 Z 81.900 32 | 3777 1-GR-R-NW3 X 155052.594 Y 517837.163 Z 81.881 33 | 3778 1-GR-R-NW3 X 155050.899 Y 517835.492 Z 81.881 34 | 3779 1-GR-R-NW3 X 155050.049 Y 517834.638 Z 81.895 35 | 3780 1-GR-R-NW3 X 155049.351 Y 517833.908 Z 81.887 36 | 3781 1-FG-R-NW3 X 155049.405 Y 517833.939 Z 81.839 37 | 3782 1-FG-R-NW3 X 155049.478 Y 517833.959 Z 81.166 38 | 3783 1-FG-R-NW3 X 155049.948 Y 517834.473 Z 81.420 39 | 3784 1-FG-R-NW3 X 155050.613 Y 517835.160 Z 81.822 40 | 3785 1-FG-R-NW3 X 155050.677 Y 517835.144 Z 81.028 41 | 3786 1-FG-R-NW3 X 155051.331 Y 517835.848 Z 81.332 42 | 3787 1-FG-R-NW3 X 155051.901 Y 517836.454 Z 81.797 43 | 3788 1-FG-R-NW3 X 155051.997 Y 517836.406 Z 80.742 44 | 3789 1-FG-R-NW3 X 155052.540 Y 517837.048 Z 81.324 45 | 3790 1-FG-R-NW3 X 155053.087 Y 517837.624 Z 81.835 46 | 3791 1-FG-R-NW3 X 155053.128 Y 517837.598 Z 80.582 47 | 3792 1-FG-R-NW3 X 155053.398 Y 517837.936 Z 81.298 48 | 3793 1-FG-R-NW3 X 155053.687 Y 517838.214 Z 81.812 49 | 3794 1-FG-R-NW3 X 155053.754 Y 517838.222 Z 80.564 50 | 3795 1-FG-R-NW3 X 155054.034 Y 517838.530 Z 81.349 51 | 3796 1-FG-R-NW3 X 155054.274 Y 517838.809 Z 81.850 52 | 3797 1-FG-R-NW3 X 155054.398 Y 517838.823 Z 80.587 53 | 3798 1-FG-R-NW3 X 155054.649 Y 517839.135 Z 81.324 54 | 3799 1-FG-R-NW3 X 155054.860 Y 517839.415 Z 81.876 55 | 3800 1-FG-R-NW3 X 155054.988 Y 517839.408 Z 80.514 56 | 3801 1-FG-R-NW3 X 155055.184 Y 517839.678 Z 81.423 57 | 3802 1-FG-R-NW3 X 155055.467 Y 517839.982 Z 81.883 58 | 3803 1-FG-R-NW3 X 155055.596 Y 517840.000 Z 80.529 59 | 3804 1-FG-R-NW3 X 155055.823 Y 517840.284 Z 81.404 60 | 3805 1-FG-R-NW3 X 155055.823 Y 517840.283 Z 81.404 61 | 3806 1-FG-R-NW3 X 155056.067 Y 517840.565 Z 81.911 62 | 3807 1-FG-R-NW3 X 155056.203 Y 517840.588 Z 80.552 63 | 3808 1-FG-R-NW3 X 155056.500 Y 517840.839 Z 80.417 64 | 3809 1-FG-R-NW3 X 155056.431 Y 517840.875 Z 81.414 65 | 3810 1-FG-R-NW3 X 155056.751 Y 517841.234 Z 81.939 66 | 3811 1-FG-R-NW3 X 155056.889 Y 517841.248 Z 80.540 67 | 3812 1-FG-R-NW3 X 155057.198 Y 517841.640 Z 81.359 68 | 3813 1-FG-R-NW3 X 155057.453 Y 517842.010 Z 81.983 69 | 3814 1-FG-R-NW3 X 155057.650 Y 517842.000 Z 80.125 70 | 3815 1-FG-R-NW3 X 155057.936 Y 517842.392 Z 81.407 71 | 3816 1-FG-R-NW3 X 155058.208 Y 517842.726 Z 82.000 72 | 3817 1-FG-R-NW3 X 155058.430 Y 517842.791 Z 80.184 73 | 3818 1-FG-R-NW3 X 155058.621 Y 517843.056 Z 81.332 74 | 3819 1-FG-R-NW3 X 155058.866 Y 517843.397 Z 82.070 75 | 3820 1-FG-R-NW3 X 155058.965 Y 517843.346 Z 80.608 76 | 3821 1-FG-R-NW3 X 155058.994 Y 517843.334 Z 80.244 77 | 3822 1-FG-R-NW3 X 155059.198 Y 517843.659 Z 81.512 78 | 3823 1-FG-R-NW3 X 155059.504 Y 517844.029 Z 82.111 79 | 3824 1-FG-R-NW3 X 155059.940 Y 517844.453 Z 82.103 80 | 3825 1-FG-R-NW3 X 155059.834 Y 517844.259 Z 81.526 81 | 3826 1-FG-R-NW3 X 155060.101 Y 517844.453 Z 80.870 82 | 3827 1-FG-R-NW3 X 155059.633 Y 517843.997 Z 80.791 83 | 3828 1-FG-R-NW3 X 155056.982 Y 517841.285 Z 80.148 -------------------------------------------------------------------------------- /src/spitcenter.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "helpfunc.h" 6 | 7 | using namespace Rcpp; 8 | 9 | // get mean z value of the four horizontally closest points to a point on a surface 10 | double refz(double x1, double y1, NumericMatrix curmap) { 11 | // find maxdist of current layer (purpose: see below) 12 | NumericVector xcl = curmap(_, 0); 13 | NumericVector ycl = curmap(_, 1); 14 | double maxdist = pyth(minv(xcl), minv(ycl), maxv(xcl), maxv(ycl)); 15 | // create vectors for individual point distances 16 | // (horizontal -> mindistps and vertical -> mindistz) 17 | NumericVector mindistps(4); 18 | NumericVector mindistz(4); 19 | for (int p1 = 0; p1 < curmap.nrow(); p1++) { 20 | // get horizontal coordinates of the current single point of the layer -> x2, y2 21 | double x2 = curmap(p1, 0); 22 | double y2 = curmap(p1, 1); 23 | // calculate horizontal euclidian distance of single point of interest and single point of layer 24 | // -> dist 25 | double dist = pyth(x1, y1, x2, y2); 26 | // at the beginning: set minimum distance value for all four closest points to maxdist - this value 27 | // will be adjusted step by step 28 | if (p1 == 0) { 29 | mindistps(0) = maxdist; 30 | mindistps(1) = maxdist; 31 | mindistps(2) = maxdist; 32 | mindistps(3) = maxdist; 33 | } 34 | int id = maxid(mindistps); 35 | // if the current point of layer has a smaller distance to the current point of interest, then 36 | // replace the biggest value in vector mindistps by new smaller value (if so) and also store z value 37 | // of the current single point of layer 38 | if (dist <= mindistps(id)) { 39 | mindistps(id) = dist; 40 | mindistz(id) = curmap(p1, 2); 41 | } 42 | } 43 | double ztop = mean(mindistz); 44 | 45 | return (ztop); 46 | } 47 | 48 | //' Center determination for hexahedrons 49 | //' 50 | //' A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 51 | //' \code{spitcenter} determines a center point for an input hexahedron by calculating the mean 52 | //' of the maximal extent on all three axis. 53 | //' 54 | //' @param hex dataframe with three columns and eight rows to define a hexahedron by its corner 55 | //' point coordinates x, y and z 56 | //' 57 | //' @return vector with the spatial coordinates of the center point of the input hexahedron 58 | //' 59 | //' @family centerdetfuncs 60 | //' 61 | //' @examples 62 | //' hexatestdf <- data.frame( 63 | //' x = c(0,1,0,4,5,5,5,5), 64 | //' y = c(1,1,4,4,1,1,4,4), 65 | //' z = c(4,8,4,9,4,8,4,6) 66 | //' ) 67 | //' 68 | //' center <- spitcenter(hexatestdf) 69 | //' 70 | //' #library(rgl) 71 | //' #plot3d( 72 | //' # hexatestdf$x, hexatestdf$y, hexatestdf$z, 73 | //' # type = "p", 74 | //' # xlab = "x", ylab = "y", zlab = "z" 75 | //' #) 76 | //' #plot3d( 77 | //' # center[1], center[2], center[3], 78 | //' # type = "p", 79 | //' # col = "red", 80 | //' # add = TRUE 81 | //' #) 82 | //' 83 | //' @export 84 | // [[Rcpp::export]] 85 | NumericVector spitcenter(DataFrame hex){ 86 | 87 | Function asMatrix("as.matrix"); 88 | 89 | SEXP hex2mid = hex; 90 | NumericMatrix hexa = asMatrix(hex2mid); 91 | 92 | NumericVector geometriccenter = NumericVector::create( 93 | _["x"] = mean(hexa(_, 0)), 94 | _["y"] = mean(hexa(_, 1)), 95 | _["z"] = mean(hexa(_, 2)) 96 | ); 97 | 98 | return geometriccenter; 99 | } 100 | 101 | //' Center determination for rectangles whose tops and bottoms are defined by irregular surfaces (3D) 102 | //' 103 | //' \code{spitcenternat} first of all calculates the horizontal center of an input rectangle. 104 | //' Then it determines the vertical positions of the center points in relation to a surface stack. 105 | //' 106 | //' @param hex data.frame with the 2D corners of the rectangle defined by four points 107 | //' @param maplist list of data.frames which contain the points that make up the surfaces 108 | //' 109 | //' @return data.frame with the spatial coordinates of the center points 110 | //' 111 | //' @family centerdetfuncs 112 | //' 113 | //' @examples 114 | //' df1 <- data.frame( 115 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 116 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 117 | //' z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 118 | //' ) 119 | //' 120 | //' df2 <- data.frame( 121 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 122 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 123 | //' z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 124 | //' ) 125 | //' 126 | //' df3 <- data.frame( 127 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 128 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 129 | //' z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 130 | //' ) 131 | //' 132 | //' lpoints <- list(df1, df2, df3) 133 | //' 134 | //' maps <- kriglist(lpoints, lags = 3, model = "spherical") 135 | //' 136 | //' hexatestdf <- data.frame( 137 | //' x = c(1, 1, 1, 1, 2, 2, 2, 2), 138 | //' y = c(0, 1, 0, 1, 0, 1, 0, 1) 139 | //' ) 140 | //' 141 | //' spitcenternat(hexatestdf, maps) 142 | //' 143 | //' @export 144 | // [[Rcpp::export]] 145 | DataFrame spitcenternat(DataFrame hex, List maplist){ 146 | 147 | Function asMatrix("as.matrix"); 148 | 149 | SEXP hex2mid = hex; 150 | NumericMatrix hexa = asMatrix(hex2mid); 151 | 152 | // get horizontal coordinates of current spit -> x1, y1 153 | double curxmean = mean(hexa(_, 0)); 154 | double curymean = mean(hexa(_, 1)); 155 | 156 | NumericMatrix respoints(maplist.size() - 1, 3); 157 | 158 | for (int mp = 0; mp < (maplist.size() - 1); mp++) { 159 | // select matrix with points of the current and the next layer -> curmaptop, curmapbottom 160 | SEXP curmapmidtop = maplist(mp); 161 | SEXP curmapmidbottom = maplist(mp + 1); 162 | NumericMatrix curmaptop = asMatrix(curmapmidtop); 163 | NumericMatrix curmapbottom = asMatrix(curmapmidbottom); 164 | 165 | NumericVector zvs(2); 166 | zvs(0) = refz(curxmean, curymean, curmaptop); 167 | zvs(1) = refz(curxmean, curymean, curmapbottom); 168 | 169 | respoints(mp, 0) = curxmean; 170 | respoints(mp, 1) = curymean; 171 | respoints(mp, 2) = mean(zvs); 172 | 173 | } 174 | 175 | NumericVector x = respoints(_, 0); 176 | NumericVector y = respoints(_, 1); 177 | NumericVector z = respoints(_, 2); 178 | 179 | // output 180 | return DataFrame::create(_["x"] = x, _["y"] = y, _["z"] = z); 181 | } 182 | 183 | //' Center determination for rectangles whose tops and bottoms are defined by irregular 184 | //' surfaces (3D) for multiple data.frames in a list 185 | //' 186 | //' \code{spitcenternatlist} works as \code{\link{spitcenternat}} but not just for a 187 | //' single data.frame but for a list of data.frames 188 | //' 189 | //' @param hexlist list of data.frames with the 2D corners of the rectangles 190 | //' @param maplist list of data.frames which contain the points that make up the surfaces 191 | //' 192 | //' @return list of data.frames with the spatial coordinates of the center points 193 | //' 194 | //' @family centerdetfuncs 195 | //' 196 | //' @examples 197 | //' df1 <- data.frame( 198 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 199 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 200 | //' z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 201 | //' ) 202 | //' 203 | //' df2 <- data.frame( 204 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 205 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 206 | //' z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 207 | //' ) 208 | //' 209 | //' df3 <- data.frame( 210 | //' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 211 | //' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 212 | //' z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 213 | //' ) 214 | //' 215 | //' lpoints <- list(df1, df2, df3) 216 | //' 217 | //' maps <- kriglist(lpoints, lags = 3, model = "spherical") 218 | //' 219 | //' hexatestdf1 <- data.frame( 220 | //' x = c(1, 1, 1, 1, 2, 2, 2, 2), 221 | //' y = c(0, 1, 0, 1, 0, 1, 0, 1) 222 | //' ) 223 | //' 224 | //' hexatestdf2 <- data.frame( 225 | //' x = c(0, 0, 0, 0, 1, 1, 1, 1), 226 | //' y = c(0, 1, 0, 1, 0, 1, 0, 1) 227 | //' ) 228 | //' 229 | //' hexs <- list(hexatestdf1, hexatestdf2) 230 | //' 231 | //' spitcenternatlist(hexs, maps) 232 | //' 233 | //' @export 234 | // [[Rcpp::export]] 235 | List spitcenternatlist(List hexlist, List maplist){ 236 | 237 | for (int crp = 0; crp < hexlist.size(); crp++){ 238 | 239 | SEXP curhexlist = hexlist[crp]; 240 | hexlist[crp] = spitcenternat(curhexlist, maplist); 241 | 242 | } 243 | 244 | return hexlist; 245 | } -------------------------------------------------------------------------------- /data-raw/KT_spits.csv: -------------------------------------------------------------------------------- 1 | id;x;y;z 2 | surface_1;6.861;19.039;9.721 3 | surface_2;6.079;18.307;9.73 4 | surface_3;5.626;17.699;9.607 5 | surface_4;4.942;17.543;9.711 6 | surface_5;4.738;16.451;9.701 7 | surface_6;5.328;16.045;9.751 8 | surface_7;5.688;16.569;9.834 9 | surface_8;6.575;16.623;9.689 10 | surface_9;6.663;17.406;9.706 11 | surface_10;7.36;17.107;9.761 12 | surface_11;8.308;17.27;9.708 13 | surface_12;9.139;16.263;9.686 14 | surface_13;8.278;16.401;9.749 15 | surface_14;7.333;16.195;9.726 16 | surface_15;6.018;15.558;9.752 17 | surface_16;6.276;14.531;9.716 18 | surface_17;7.025;15.064;9.665 19 | surface_18;8.388;15.59;9.696 20 | surface_19;9.227;15.397;9.604 21 | surface_20;8.43;14.197;9.64 22 | surface_21;9.187;14.587;9.63 23 | surface_22;10.278;14.573;9.626 24 | surface_23;8.938;13.416;9.642 25 | surface_24;7.348;13.744;9.676 26 | surface_25;7.6;14.372;9.667 27 | surface_26;7.353;13.744;9.678 28 | surface_27;6.842;13.188;9.675 29 | surface_28;7.684;12.407;9.774 30 | surface_29;7.143;12.12;9.654 31 | surface_30;5.502;13.597;9.745 32 | surface_31;4.994;15.225;9.8 33 | surface_32;4.336;15.559;9.771 34 | surface_33;4.02;16.587;9.721 35 | surface_34;2.399;15.413;9.739 36 | surface_35;3.833;14.698;9.731 37 | surface_36;4.335;14.145;9.798 38 | surface_37;4.187;13.544;9.761 39 | surface_38;3.298;14.172;9.754 40 | surface_39;3.386;13.357;9.747 41 | surface_40;4.985;12.584;9.85 42 | surface_41;4.265;12.268;9.651 43 | surface_42;3.755;12.038;9.676 44 | surface_43;4.421;11.181;9.744 45 | surface_44;5.071;11.356;9.647 46 | surface_45;5.82;12.382;9.628 47 | surface_46;5.71;11.14;9.634 48 | surface_47;5.031;10.294;9.666 49 | surface_48;4.417;9.796;9.705 50 | surface_49;3.474;11.055;9.654 51 | surface_50;2.956;12.077;9.706 52 | surface_51;2.739;12.547;9.65 53 | surface_52;1.955;12.988;9.725 54 | surface_53;2.282;13.69;9.848 55 | surface_54;2.283;14.176;9.797 56 | surface_55;0.9;14.278;9.819 57 | spit1_1;6.873;19.069;9.381 58 | spit1_2;6.892;18.043;9.389 59 | spit1_3;7.708;18.074;9.411 60 | spit1_4;8.21;17.166;9.352 61 | spit1_5;8.087;16.608;9.329 62 | spit1_6;7.61;15.932;9.314 63 | spit1_7;8.574;15.648;9.318 64 | spit1_8;9.253;16.058;9.338 65 | spit1_9;9.067;15;9.31 66 | spit1_10;10.414;14.59;9.293 67 | spit1_11;9.438;13.829;9.323 68 | spit1_12;6.844;17.223;9.36 69 | spit1_13;5.886;18.292;9.38 70 | spit1_14;5.632;16.887;9.502 71 | spit1_15;6.265;16.476;9.447 72 | spit1_16;6.634;16.158;9.328 73 | spit1_17;7.937;15.003;9.303 74 | spit1_18;8.44;14.276;9.31 75 | spit1_19;8.347;12.994;9.351 76 | spit1_20;7.825;14.14;9.316 77 | spit1_21;7.422;14.152;9.485 78 | spit1_22;6.339;15.341;9.322 79 | spit1_23;5.905;16.181;9.542 80 | spit1_24;4.708;17.262;9.421 81 | spit1_25;4.689;15.948;9.46 82 | spit1_26;5.154;15.776;9.575 83 | spit1_27;5.606;15.566;9.476 84 | spit1_28;6.223;14.825;9.363 85 | spit1_29;6.706;14.179;9.374 86 | spit1_30;7.486;13.252;9.34 87 | spit1_31;7.604;12.377;9.369 88 | spit1_32;6.48;12.473;9.353 89 | spit1_33;6.555;13.114;9.398 90 | spit1_34;6.593;13.571;9.456 91 | spit1_35;5.473;14.269;9.393 92 | spit1_36;4.736;15.344;9.481 93 | spit1_37;3.853;16.423;9.496 94 | spit1_38;3.132;16.132;9.547 95 | spit1_39;3.651;15.372;9.582 96 | spit1_40;4.212;14.395;9.509 97 | spit1_41;5.617;13.279;9.482 98 | spit1_42;6.558;11.423;9.335 99 | spit1_43;5.482;12.471;9.446 100 | spit1_44;5.51;11.606;9.279 101 | spit1_45;4.621;12.958;9.452 102 | spit1_46;3.866;13.527;9.499 103 | spit1_47;3.533;14.488;9.44 104 | spit1_48;2.906;15.24;9.411 105 | spit1_49;2.152;15.42;9.549 106 | spit1_50;1.959;14.331;9.562 107 | spit1_51;2.694;14.214;9.527 108 | spit1_52;2.746;13.518;9.454 109 | spit1_53;3.472;12.817;9.483 110 | spit1_54;4.379;12.076;9.458 111 | spit1_55;5.572;10.725;9.303 112 | spit1_56;4.287;10.706;9.367 113 | spit1_57;4.464;11.227;9.376 114 | spit1_58;4.41;9.803;9.504 115 | spit1_59;3.299;11.302;9.376 116 | spit1_60;2.951;12.074;9.546 117 | spit1_61;2.558;12.877;9.373 118 | spit1_62;2.196;12.788;9.423 119 | spit1_63;1.482;13.481;9.382 120 | spit1_64;0.886;14.345;9.585 121 | spit2_1;6.87;19.01;9.122 122 | spit2_2;7.431;17.742;9.154 123 | spit2_3;8.032;17.449;9.117 124 | spit2_4;8.65;16.562;9.071 125 | spit2_5;9.289;15.858;9.066 126 | spit2_6;10.209;14.531;9.052 127 | spit2_7;9.084;14.739;9.05 128 | spit2_8;8.667;15.65;9.07 129 | spit2_9;8.152;16.093;9.07 130 | spit2_10;7.547;16.687;9.108 131 | spit2_11;6.595;17.502;9.141 132 | spit2_12;6.048;18.261;9.135 133 | spit2_13;5.146;17.62;9.097 134 | spit2_14;5.951;17.202;9.09 135 | spit2_15;5.249;17.081;9.095 136 | spit2_16;6.689;16.106;9.082 137 | spit2_17;7.081;15.609;9.099 138 | spit2_18;7.59;14.964;9.117 139 | spit2_19;8.442;15.08;9.037 140 | spit2_20;8.396;14.171;9.09 141 | spit2_21;8.803;13.37;9.107 142 | spit2_22;7.875;13.116;9.104 143 | spit2_23;7.43;13.772;9.073 144 | spit2_24;7.29;12.833;9.116 145 | spit2_25;6.48;13.954;9.123 146 | spit2_26;7.179;12.074;9.112 147 | spit2_27;6.397;13.115;9.077 148 | spit2_28;5.78;13.461;9.113 149 | spit2_29;5.2;14.159;9.109 150 | spit2_30;6.376;12.467;9.116 151 | spit2_31;6.231;11.308;9.071 152 | spit2_32;5.565;12.192;9.095 153 | spit2_33;5.227;12.793;9.079 154 | spit2_34;5.146;13.495;9.085 155 | spit2_35;4.546;13.702;9.079 156 | spit2_36;5.035;11.404;9.108 157 | spit2_37;5.053;10.428;9.101 158 | spit2_38;4.415;9.871;9.155 159 | spit2_39;4.256;10.895;9.115 160 | spit2_40;3.392;11.108;9.126 161 | spit2_41;4.108;11.81;9.121 162 | spit2_42;4.225;12.784;9.071 163 | spit2_43;2.727;11.969;9.054 164 | spit2_44;3.455;12.81;9.067 165 | spit2_45;2.068;12.866;9.026 166 | spit2_46;2.676;13.622;9.036 167 | spit2_47;2.225;14.322;9.082 168 | spit2_48;1.6;13.978;9.068 169 | spit2_49;1.022;14.297;9.084 170 | spit2_50;2.425;15.564;9.142 171 | spit2_51;3.52;14.299;9.031 172 | spit2_52;3.193;15.128;9.117 173 | spit2_53;3.215;15.874;9.091 174 | spit2_54;3.838;15.445;9.068 175 | spit2_55;4.255;14.513;9.075 176 | spit2_56;4.55;15.52;9.068 177 | spit2_57;4.192;16.235;9.091 178 | spit2_58;3.827;16.554;9.123 179 | spit2_59;5.389;15.332;9.087 180 | spit2_60;5.521;15.993;9.058 181 | spit2_61;5.149;16.449;8.993 182 | spit3_1;10.08;14.427;8.741 183 | spit3_2;9.584;15.57;8.771 184 | spit3_3;8.967;16.309;8.756 185 | spit3_4;8.372;17.09;8.782 186 | spit3_5;7.789;17.835;8.85 187 | spit3_6;7.226;18.574;8.813 188 | spit3_7;6.833;18.994;8.795 189 | spit3_8;6.304;18.509;8.77 190 | spit3_9;7.111;17.84;8.831 191 | spit3_10;6.894;16.831;8.802 192 | spit3_11;6.28;17.556;8.831 193 | spit3_12;7.729;16.413;8.762 194 | spit3_13;6.572;16.138;8.773 195 | spit3_14;7.264;15.584;8.755 196 | spit3_15;8.696;15.538;8.766 197 | spit3_16;8.388;14.726;8.742 198 | spit3_17;9.13;14.236;8.772 199 | spit3_18;8.788;13.385;8.783 200 | spit3_19;8.009;13.334;8.777 201 | spit3_20;7.432;14.69;8.797 202 | spit3_21;7.43;13.754;8.761 203 | spit3_22;6.802;14.07;8.793 204 | spit3_23;7.268;12.769;8.802 205 | spit3_24;7.174;12.102;8.799 206 | spit3_25;6.286;12.785;8.754 207 | spit3_26;5.623;13.475;8.787 208 | spit3_27;5.502;14.408;8.803 209 | spit3_28;6.341;11.849;8.785 210 | spit3_29;6.024;11.127;8.715 211 | spit3_30;5.392;11.782;8.76 212 | spit3_31;5.485;12.522;8.788 213 | spit3_32;4.914;12.931;8.756 214 | spit3_33;4.223;12.826;8.753 215 | spit3_34;4.039;12.041;8.74 216 | spit3_35;4.578;11.414;8.775 217 | spit3_36;5.206;11.167;8.756 218 | spit3_37;5.097;10.383;8.78 219 | spit3_38;4.394;9.891;8.841 220 | spit3_39;3.87;10.548;8.814 221 | spit3_40;3.251;11.328;8.79 222 | spit3_41;3.338;12.107;8.744 223 | spit3_42;3.52;12.823;8.762 224 | spit3_43;2.535;12.302;8.731 225 | spit3_44;2.026;12.996;8.726 226 | spit3_45;2.997;13.512;8.726 227 | spit3_46;2.528;14.523;8.786 228 | spit3_47;1.571;14.738;8.795 229 | spit3_48;2.312;15.423;8.839 230 | spit3_49;3.165;14.802;8.8 231 | spit3_50;3.61;14.338;8.726 232 | spit3_51;4.348;14.164;8.776 233 | spit3_52;4.305;14.88;8.778 234 | spit3_53;3.842;15.618;8.762 235 | spit3_54;2.966;15.972;8.795 236 | spit3_55;3.773;16.577;8.817 237 | spit3_56;4.734;16.043;8.755 238 | spit3_57;5.25;15.23;8.796 239 | spit3_58;5.84;16.013;8.708 240 | spit3_59;5.589;17.211;8.766 241 | spit3_60;5.576;18.004;8.818 242 | spit3_61;4.704;17.301;8.783 243 | bottom_1;10.17;14.508;8.401 244 | bottom_2;9.536;15.529;8.405 245 | bottom_3;8.723;16.538;8.369 246 | bottom_4;7.932;17.607;8.372 247 | bottom_5;6.827;18.979;8.41 248 | bottom_6;7.001;18.196;8.406 249 | bottom_7;7.142;16.817;8.381 250 | bottom_8;7.846;15.944;8.382 251 | bottom_9;8.589;15.691;8.385 252 | bottom_10;8.829;14.951;8.396 253 | bottom_11;9.21;14.172;8.403 254 | bottom_12;6.561;17.308;8.4 255 | bottom_13;5.963;18.287;8.403 256 | bottom_14;5.088;17.515;8.422 257 | bottom_15;5.577;16.842;8.401 258 | bottom_16;6.517;16.094;8.386 259 | bottom_17;7.352;15.451;8.4 260 | bottom_18;7.884;14.969;8.395 261 | bottom_19;8.494;14.166;8.381 262 | bottom_20;8.787;13.347;8.398 263 | bottom_21;7.813;14.197;8.375 264 | bottom_22;7.24;14.481;8.387 265 | bottom_23;8.084;13.437;8.372 266 | bottom_24;7.324;13.604;8.373 267 | bottom_25;7.317;12.825;8.358 268 | bottom_26;6.248;13.768;8.358 269 | bottom_27;6.303;14.932;8.188 270 | bottom_28;5.427;14.308;8.382 271 | bottom_29;5.839;13.211;8.367 272 | bottom_30;6.392;12.82;8.359 273 | bottom_31;7.06;11.997;8.363 274 | bottom_32;6.043;11.181;8.382 275 | bottom_33;5.757;12.211;8.361 276 | bottom_34;5.047;12.888;8.374 277 | bottom_35;5.225;13.677;8.357 278 | bottom_36;4.519;13.769;8.356 279 | bottom_37;5.347;11.452;8.392 280 | bottom_38;4.607;11.376;8.397 281 | bottom_39;5.12;10.482;8.427 282 | bottom_40;4.445;9.885;8.451 283 | bottom_41;4.418;10.592;8.419 284 | bottom_42;3.678;10.74;8.42 285 | bottom_43;3.693;11.768;8.354 286 | bottom_44;2.769;11.946;8.334 287 | bottom_45;3.697;12.675;8.348 288 | bottom_46;4.283;12.84;8.346 289 | bottom_47;2.881;12.577;8.289 290 | bottom_48;3.113;13.141;8.313 291 | bottom_49;2.074;12.863;8.327 292 | bottom_50;2.444;13.644;8.344 293 | bottom_51;3.219;14.115;8.36 294 | bottom_52;2.415;14.467;8.382 295 | bottom_53;1.574;14.678;8.424 296 | bottom_54;2.327;15.37;8.39 297 | bottom_55;3.23;15.011;8.357 298 | bottom_56;3.198;16.076;8.359 299 | bottom_57;3.916;15.589;8.366 300 | bottom_58;4.13;14.662;8.397 301 | bottom_59;4.71;15.238;8.384 302 | bottom_60;4.357;16.023;8.378 303 | bottom_61;4.227;16.873;8.366 304 | bottom_62;5.539;15.668;8.369 305 | bottom_63;3.915;13.486;8.293 -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | // draw_circle 9 | DataFrame draw_circle(double centerx, double centery, double centerz, double radius, int resolution); 10 | RcppExport SEXP _recexcavAAR_draw_circle(SEXP centerxSEXP, SEXP centerySEXP, SEXP centerzSEXP, SEXP radiusSEXP, SEXP resolutionSEXP) { 11 | BEGIN_RCPP 12 | Rcpp::RObject rcpp_result_gen; 13 | Rcpp::RNGScope rcpp_rngScope_gen; 14 | Rcpp::traits::input_parameter< double >::type centerx(centerxSEXP); 15 | Rcpp::traits::input_parameter< double >::type centery(centerySEXP); 16 | Rcpp::traits::input_parameter< double >::type centerz(centerzSEXP); 17 | Rcpp::traits::input_parameter< double >::type radius(radiusSEXP); 18 | Rcpp::traits::input_parameter< int >::type resolution(resolutionSEXP); 19 | rcpp_result_gen = Rcpp::wrap(draw_circle(centerx, centery, centerz, radius, resolution)); 20 | return rcpp_result_gen; 21 | END_RCPP 22 | } 23 | // rotate 24 | DataFrame rotate(NumericVector x, NumericVector y, NumericVector z, double degrx, double degry, double degrz, double pivotx, double pivoty, double pivotz); 25 | RcppExport SEXP _recexcavAAR_rotate(SEXP xSEXP, SEXP ySEXP, SEXP zSEXP, SEXP degrxSEXP, SEXP degrySEXP, SEXP degrzSEXP, SEXP pivotxSEXP, SEXP pivotySEXP, SEXP pivotzSEXP) { 26 | BEGIN_RCPP 27 | Rcpp::RObject rcpp_result_gen; 28 | Rcpp::RNGScope rcpp_rngScope_gen; 29 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 30 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); 31 | Rcpp::traits::input_parameter< NumericVector >::type z(zSEXP); 32 | Rcpp::traits::input_parameter< double >::type degrx(degrxSEXP); 33 | Rcpp::traits::input_parameter< double >::type degry(degrySEXP); 34 | Rcpp::traits::input_parameter< double >::type degrz(degrzSEXP); 35 | Rcpp::traits::input_parameter< double >::type pivotx(pivotxSEXP); 36 | Rcpp::traits::input_parameter< double >::type pivoty(pivotySEXP); 37 | Rcpp::traits::input_parameter< double >::type pivotz(pivotzSEXP); 38 | rcpp_result_gen = Rcpp::wrap(rotate(x, y, z, degrx, degry, degrz, pivotx, pivoty, pivotz)); 39 | return rcpp_result_gen; 40 | END_RCPP 41 | } 42 | // draw_sphere 43 | DataFrame draw_sphere(double centerx, double centery, double centerz, double radius, int phires, int thetares); 44 | RcppExport SEXP _recexcavAAR_draw_sphere(SEXP centerxSEXP, SEXP centerySEXP, SEXP centerzSEXP, SEXP radiusSEXP, SEXP phiresSEXP, SEXP thetaresSEXP) { 45 | BEGIN_RCPP 46 | Rcpp::RObject rcpp_result_gen; 47 | Rcpp::RNGScope rcpp_rngScope_gen; 48 | Rcpp::traits::input_parameter< double >::type centerx(centerxSEXP); 49 | Rcpp::traits::input_parameter< double >::type centery(centerySEXP); 50 | Rcpp::traits::input_parameter< double >::type centerz(centerzSEXP); 51 | Rcpp::traits::input_parameter< double >::type radius(radiusSEXP); 52 | Rcpp::traits::input_parameter< int >::type phires(phiresSEXP); 53 | Rcpp::traits::input_parameter< int >::type thetares(thetaresSEXP); 54 | rcpp_result_gen = Rcpp::wrap(draw_sphere(centerx, centery, centerz, radius, phires, thetares)); 55 | return rcpp_result_gen; 56 | END_RCPP 57 | } 58 | // rescale 59 | DataFrame rescale(NumericVector x, NumericVector y, NumericVector z, double scalex, double scaley, double scalez); 60 | RcppExport SEXP _recexcavAAR_rescale(SEXP xSEXP, SEXP ySEXP, SEXP zSEXP, SEXP scalexSEXP, SEXP scaleySEXP, SEXP scalezSEXP) { 61 | BEGIN_RCPP 62 | Rcpp::RObject rcpp_result_gen; 63 | Rcpp::RNGScope rcpp_rngScope_gen; 64 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 65 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); 66 | Rcpp::traits::input_parameter< NumericVector >::type z(zSEXP); 67 | Rcpp::traits::input_parameter< double >::type scalex(scalexSEXP); 68 | Rcpp::traits::input_parameter< double >::type scaley(scaleySEXP); 69 | Rcpp::traits::input_parameter< double >::type scalez(scalezSEXP); 70 | rcpp_result_gen = Rcpp::wrap(rescale(x, y, z, scalex, scaley, scalez)); 71 | return rcpp_result_gen; 72 | END_RCPP 73 | } 74 | // fillhexa 75 | DataFrame fillhexa(DataFrame hex, double res); 76 | RcppExport SEXP _recexcavAAR_fillhexa(SEXP hexSEXP, SEXP resSEXP) { 77 | BEGIN_RCPP 78 | Rcpp::RObject rcpp_result_gen; 79 | Rcpp::RNGScope rcpp_rngScope_gen; 80 | Rcpp::traits::input_parameter< DataFrame >::type hex(hexSEXP); 81 | Rcpp::traits::input_parameter< double >::type res(resSEXP); 82 | rcpp_result_gen = Rcpp::wrap(fillhexa(hex, res)); 83 | return rcpp_result_gen; 84 | END_RCPP 85 | } 86 | // pnp 87 | bool pnp(NumericVector vertx, NumericVector verty, float testx, float testy); 88 | RcppExport SEXP _recexcavAAR_pnp(SEXP vertxSEXP, SEXP vertySEXP, SEXP testxSEXP, SEXP testySEXP) { 89 | BEGIN_RCPP 90 | Rcpp::RObject rcpp_result_gen; 91 | Rcpp::RNGScope rcpp_rngScope_gen; 92 | Rcpp::traits::input_parameter< NumericVector >::type vertx(vertxSEXP); 93 | Rcpp::traits::input_parameter< NumericVector >::type verty(vertySEXP); 94 | Rcpp::traits::input_parameter< float >::type testx(testxSEXP); 95 | Rcpp::traits::input_parameter< float >::type testy(testySEXP); 96 | rcpp_result_gen = Rcpp::wrap(pnp(vertx, verty, testx, testy)); 97 | return rcpp_result_gen; 98 | END_RCPP 99 | } 100 | // pnpmulti 101 | LogicalVector pnpmulti(NumericVector vertx, NumericVector verty, NumericVector testx, NumericVector testy); 102 | RcppExport SEXP _recexcavAAR_pnpmulti(SEXP vertxSEXP, SEXP vertySEXP, SEXP testxSEXP, SEXP testySEXP) { 103 | BEGIN_RCPP 104 | Rcpp::RObject rcpp_result_gen; 105 | Rcpp::RNGScope rcpp_rngScope_gen; 106 | Rcpp::traits::input_parameter< NumericVector >::type vertx(vertxSEXP); 107 | Rcpp::traits::input_parameter< NumericVector >::type verty(vertySEXP); 108 | Rcpp::traits::input_parameter< NumericVector >::type testx(testxSEXP); 109 | Rcpp::traits::input_parameter< NumericVector >::type testy(testySEXP); 110 | rcpp_result_gen = Rcpp::wrap(pnpmulti(vertx, verty, testx, testy)); 111 | return rcpp_result_gen; 112 | END_RCPP 113 | } 114 | // posdec 115 | DataFrame posdec(DataFrame crdf, List maplist); 116 | RcppExport SEXP _recexcavAAR_posdec(SEXP crdfSEXP, SEXP maplistSEXP) { 117 | BEGIN_RCPP 118 | Rcpp::RObject rcpp_result_gen; 119 | Rcpp::RNGScope rcpp_rngScope_gen; 120 | Rcpp::traits::input_parameter< DataFrame >::type crdf(crdfSEXP); 121 | Rcpp::traits::input_parameter< List >::type maplist(maplistSEXP); 122 | rcpp_result_gen = Rcpp::wrap(posdec(crdf, maplist)); 123 | return rcpp_result_gen; 124 | END_RCPP 125 | } 126 | // posdeclist 127 | List posdeclist(List crdflist, List maplist); 128 | RcppExport SEXP _recexcavAAR_posdeclist(SEXP crdflistSEXP, SEXP maplistSEXP) { 129 | BEGIN_RCPP 130 | Rcpp::RObject rcpp_result_gen; 131 | Rcpp::RNGScope rcpp_rngScope_gen; 132 | Rcpp::traits::input_parameter< List >::type crdflist(crdflistSEXP); 133 | Rcpp::traits::input_parameter< List >::type maplist(maplistSEXP); 134 | rcpp_result_gen = Rcpp::wrap(posdeclist(crdflist, maplist)); 135 | return rcpp_result_gen; 136 | END_RCPP 137 | } 138 | // spatiallong 139 | DataFrame spatiallong(NumericVector x, NumericVector y, NumericMatrix z); 140 | RcppExport SEXP _recexcavAAR_spatiallong(SEXP xSEXP, SEXP ySEXP, SEXP zSEXP) { 141 | BEGIN_RCPP 142 | Rcpp::RObject rcpp_result_gen; 143 | Rcpp::RNGScope rcpp_rngScope_gen; 144 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 145 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); 146 | Rcpp::traits::input_parameter< NumericMatrix >::type z(zSEXP); 147 | rcpp_result_gen = Rcpp::wrap(spatiallong(x, y, z)); 148 | return rcpp_result_gen; 149 | END_RCPP 150 | } 151 | // spatialwide 152 | List spatialwide(NumericVector x, NumericVector y, NumericVector z, int digits); 153 | RcppExport SEXP _recexcavAAR_spatialwide(SEXP xSEXP, SEXP ySEXP, SEXP zSEXP, SEXP digitsSEXP) { 154 | BEGIN_RCPP 155 | Rcpp::RObject rcpp_result_gen; 156 | Rcpp::RNGScope rcpp_rngScope_gen; 157 | Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); 158 | Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); 159 | Rcpp::traits::input_parameter< NumericVector >::type z(zSEXP); 160 | Rcpp::traits::input_parameter< int >::type digits(digitsSEXP); 161 | rcpp_result_gen = Rcpp::wrap(spatialwide(x, y, z, digits)); 162 | return rcpp_result_gen; 163 | END_RCPP 164 | } 165 | // spitcenter 166 | NumericVector spitcenter(DataFrame hex); 167 | RcppExport SEXP _recexcavAAR_spitcenter(SEXP hexSEXP) { 168 | BEGIN_RCPP 169 | Rcpp::RObject rcpp_result_gen; 170 | Rcpp::RNGScope rcpp_rngScope_gen; 171 | Rcpp::traits::input_parameter< DataFrame >::type hex(hexSEXP); 172 | rcpp_result_gen = Rcpp::wrap(spitcenter(hex)); 173 | return rcpp_result_gen; 174 | END_RCPP 175 | } 176 | // spitcenternat 177 | DataFrame spitcenternat(DataFrame hex, List maplist); 178 | RcppExport SEXP _recexcavAAR_spitcenternat(SEXP hexSEXP, SEXP maplistSEXP) { 179 | BEGIN_RCPP 180 | Rcpp::RObject rcpp_result_gen; 181 | Rcpp::RNGScope rcpp_rngScope_gen; 182 | Rcpp::traits::input_parameter< DataFrame >::type hex(hexSEXP); 183 | Rcpp::traits::input_parameter< List >::type maplist(maplistSEXP); 184 | rcpp_result_gen = Rcpp::wrap(spitcenternat(hex, maplist)); 185 | return rcpp_result_gen; 186 | END_RCPP 187 | } 188 | // spitcenternatlist 189 | List spitcenternatlist(List hexlist, List maplist); 190 | RcppExport SEXP _recexcavAAR_spitcenternatlist(SEXP hexlistSEXP, SEXP maplistSEXP) { 191 | BEGIN_RCPP 192 | Rcpp::RObject rcpp_result_gen; 193 | Rcpp::RNGScope rcpp_rngScope_gen; 194 | Rcpp::traits::input_parameter< List >::type hexlist(hexlistSEXP); 195 | Rcpp::traits::input_parameter< List >::type maplist(maplistSEXP); 196 | rcpp_result_gen = Rcpp::wrap(spitcenternatlist(hexlist, maplist)); 197 | return rcpp_result_gen; 198 | END_RCPP 199 | } 200 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #' Draws a circular point cloud (3D) 5 | #' 6 | #' @description 7 | #' Draws a 2D circle on x- and y-plane around a center point in 3D space. 8 | #' 9 | #' @param centerx x axis value of circle center point 10 | #' @param centery y axis value of circle center point 11 | #' @param centerz z axis value of circle center point 12 | #' @param radius circle radius 13 | #' @param resolution amount of circle points (default = 30) 14 | #' 15 | #' @return 16 | #' data.frame with the spatial coordinates of the resulting points 17 | #' 18 | #' @examples 19 | #' draw_circle( 20 | #' centerx = 4, 21 | #' centery = 5, 22 | #' centerz = 1, 23 | #' radius = 3, 24 | #' resolution = 20 25 | #' ) 26 | #' 27 | #' circ <- draw_circle(1,2,3,2) 28 | #' 29 | #' plot(circ$x, circ$y) 30 | #' 31 | #' @export 32 | draw_circle <- function(centerx, centery, centerz, radius, resolution = 30L) { 33 | .Call('_recexcavAAR_draw_circle', PACKAGE = 'recexcavAAR', centerx, centery, centerz, radius, resolution) 34 | } 35 | 36 | #' Rotate a point cloud around a pivot point (3D) 37 | #' 38 | #' @description 39 | #' Rotate a point cloud around a defined pivot point by defined angles. The default 40 | #' rotation angle around each axis is zero and the default pivot point is the center 41 | #' point of the point cloud (defined by mean()) 42 | #' 43 | #' @param x vector of x axis values of rotation point cloud 44 | #' @param y vector of y axis values of rotation point cloud 45 | #' @param z vector of z axis values of rotation point cloud 46 | #' @param degrx rotation angle around x axis in degree (default = 0) 47 | #' @param degry rotation angle around y axis in degree (default = 0) 48 | #' @param degrz rotation angle around z axis in degree (default = 0) 49 | #' @param pivotx x axis value of pivot point (default = mean(x)) 50 | #' @param pivoty y axis value of pivot point (default = mean(y)) 51 | #' @param pivotz z axis value of pivot point (default = mean(z)) 52 | #' 53 | #' @return 54 | #' data.frame with the spatial coordinates of the resulting points 55 | #' 56 | #' @examples 57 | #' circ <- draw_circle(0,0,0,5) 58 | #' 59 | #' #library(rgl) 60 | #' #plot3d( 61 | #' # circ, 62 | #' # xlim = c(-6,6), 63 | #' # ylim = c(-6,6), 64 | #' # zlim = c(-6,6) 65 | #' #) 66 | #' 67 | #' rotcirc <- rotate(circ$x, circ$y, circ$z, degrx = 45) 68 | #' 69 | #' #plot3d( 70 | #' # rotcirc, 71 | #' # xlim = c(-6,6), 72 | #' # ylim = c(-6,6), 73 | #' # zlim = c(-6,6) 74 | #' #) 75 | #' 76 | #' @export 77 | rotate <- function(x, y, z, degrx = 0.0, degry = 0.0, degrz = 0.0, pivotx = NA_real_, pivoty = NA_real_, pivotz = NA_real_) { 78 | .Call('_recexcavAAR_rotate', PACKAGE = 'recexcavAAR', x, y, z, degrx, degry, degrz, pivotx, pivoty, pivotz) 79 | } 80 | 81 | #' Draws a spherical point cloud (3D) 82 | #' 83 | #' @description 84 | #' Draws a sphere around a center point in 3D space. 85 | #' 86 | #' @param centerx x axis value of sphere center point 87 | #' @param centery y axis value of sphere center point 88 | #' @param centerz z axis value of sphere center point 89 | #' @param radius sphere radius 90 | #' @param phires phi resolution (default = 10) 91 | #' @param thetares theta resolution (default = 10) 92 | #' 93 | #' @return 94 | #' data.frame with the spatial coordinates of the resulting points 95 | #' 96 | #' @examples 97 | #' sphere <- draw_sphere( 98 | #' centerx = 4, 99 | #' centery = 5, 100 | #' centerz = 1, 101 | #' radius = 3, 102 | #' phires = 20, 103 | #' thetares = 20 104 | #' ) 105 | #' 106 | #' #library(rgl) 107 | #' #plot3d(sphere) 108 | #' 109 | #' @export 110 | draw_sphere <- function(centerx, centery, centerz, radius, phires = 10L, thetares = 10L) { 111 | .Call('_recexcavAAR_draw_sphere', PACKAGE = 'recexcavAAR', centerx, centery, centerz, radius, phires, thetares) 112 | } 113 | 114 | #' Scales a point cloud (3D) 115 | #' 116 | #' @description 117 | #' Scales a 3D point cloud on every axis. 118 | #' 119 | #' @param x vector of x axis values of scale point cloud 120 | #' @param y vector of y axis values of scale point cloud 121 | #' @param z vector of z axis values of scale point cloud 122 | #' @param scalex scaling factor on x axis (default = 1) 123 | #' @param scaley scaling factor on y axis (default = 1) 124 | #' @param scalez scaling factor on z axis (default = 1) 125 | #' 126 | #' @return 127 | #' data.frame with the spatial coordinates of the resulting points 128 | #' 129 | #' @examples 130 | #' s <- draw_sphere(1,1,1,3) 131 | #' 132 | #' #library(rgl) 133 | #' #plot3d(s) 134 | #' 135 | #' s2 <- rescale(s$x, s$y, s$z, scalex = 4, scalez = 5) 136 | #' 137 | #' #library(rgl) 138 | #' #plot3d(s2) 139 | #' 140 | #' @export 141 | rescale <- function(x, y, z, scalex = 1, scaley = 1, scalez = 1) { 142 | .Call('_recexcavAAR_rescale', PACKAGE = 'recexcavAAR', x, y, z, scalex, scaley, scalez) 143 | } 144 | 145 | #' Fills hexahedrons with a regular point raster (3D) 146 | #' 147 | #' @description 148 | #' A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 149 | #' \code{fillhexa} allows to fill such a shape with a regular point raster. 150 | #' 151 | #' @details 152 | #' See \url{https://stackoverflow.com/questions/36115215/filling-a-3d-body-with-a-systematic-point-raster} 153 | #' for a description of the function and how it was developed. 154 | #' 155 | #' @param hex dataframe with three columns and eight rows to define a hexahedron by its corner 156 | #' point coordinates x, y and z 157 | #' @param res numeric value > 0 and <= 1 for the resolution of the point raster 158 | #' 159 | #' @return data.frame with the spatial coordinates of the resulting points of the grid 160 | #' 161 | #' @examples 162 | #' hexatestdf <- data.frame( 163 | #' x = c(0,1,0,4,5,5,5,5), 164 | #' y = c(1,1,4,4,1,1,4,4), 165 | #' z = c(4,8,4,9,4,8,4,6) 166 | #' ) 167 | #' 168 | #' cx = fillhexa(hexatestdf, 0.1) 169 | #' 170 | #' #library(rgl) 171 | #' #plot3d( 172 | #' # cx[,1], cx[,2], cx[,3], 173 | #' # type = "p", 174 | #' # xlab = "x", ylab = "y", zlab = "z" 175 | #' #) 176 | #' 177 | #' @export 178 | fillhexa <- function(hex, res) { 179 | .Call('_recexcavAAR_fillhexa', PACKAGE = 'recexcavAAR', hex, res) 180 | } 181 | 182 | #' Check if a point is within a polygon (2D) 183 | #' 184 | #' @description 185 | #' \code{pnp} is able to determine if a point is within a polygon in 2D space. 186 | #' The polygon is described by its corner points. The points must be in a correct 187 | #' drawing order. 188 | #' 189 | #' Based on this solution: 190 | #' Copyright (c) 1970-2003, Wm. Randolph Franklin 191 | #' \url{http://wrf.ecse.rpi.edu/pmwiki/pmwiki.php/Main/Software#toc24} 192 | #' 193 | #' @details 194 | #' For discussion see: \url{http://stackoverflow.com/questions/217578/how-can-i-determine-whether-a-2d-point-is-within-a-polygon/2922778#2922778} 195 | #' 196 | #' @param vertx vector of x axis values of polygon corner points 197 | #' @param verty vector of y axis values of polygon corner points 198 | #' @param testx x axis value of point of interest 199 | #' @param testy y axis value of point of interest 200 | #' 201 | #' @return boolean value - TRUE, if the point is within the polygon. Otherwise FALSE. 202 | #' 203 | #' @family pnpfuncs 204 | #' 205 | #' @examples 206 | #' df <- data.frame( 207 | #' x = c(1,1,2,2), 208 | #' y = c(1,2,1,2) 209 | #' ) 210 | #' 211 | #' pnp(df$x, df$y, 1.5, 1.5) 212 | #' pnp(df$x, df$y, 2.5, 2.5) 213 | #' 214 | #' # caution: false-negatives in edge-cases: 215 | #' pnp(df$x, df$y, 2, 1.5) 216 | #' 217 | #' @export 218 | pnp <- function(vertx, verty, testx, testy) { 219 | .Call('_recexcavAAR_pnp', PACKAGE = 'recexcavAAR', vertx, verty, testx, testy) 220 | } 221 | 222 | #' Check if multiple points are within a polygon (2D) 223 | #' 224 | #' @description 225 | #' \code{pnpmulti} works as \code{\link{pnp}} but for multiple points. 226 | #' 227 | #' @param vertx vector of x axis values of polygon corner points 228 | #' @param verty vector of y axis values of polygon corner points 229 | #' @param testx vector of x axis values of points of interest 230 | #' @param testy vector of y axis values of points of interest 231 | #' 232 | #' @return vector with boolean values - TRUE, if the respective point is within the polygon. 233 | #' Otherwise FALSE. 234 | #' 235 | #' @examples 236 | #' polydf <- data.frame( 237 | #' x = c(1,1,2,2), 238 | #' y = c(1,2,1,2) 239 | #' ) 240 | #' 241 | #' testdf <- data.frame( 242 | #' x = c(1.5, 2.5), 243 | #' y = c(1.5, 2.5) 244 | #' ) 245 | #' 246 | #' pnpmulti(polydf$x, polydf$y, testdf$x, testdf$y) 247 | #' 248 | #' @family pnpfuncs 249 | #' 250 | #' @export 251 | pnpmulti <- function(vertx, verty, testx, testy) { 252 | .Call('_recexcavAAR_pnpmulti', PACKAGE = 'recexcavAAR', vertx, verty, testx, testy) 253 | } 254 | 255 | #' Multiple point position decision in relation to a set of stacked surfaces (3D) 256 | #' 257 | #' \code{posdec} has the purpose to make a decision about the position of individual points in relation 258 | #' to a set of stacked surfaces in 3D space. The decision is made by comparing the mean z axis value of 259 | #' the four horizontally closest points of a surface to the z axis value of the point in question. 260 | #' 261 | #' @param crdf data.frame with the spatial coordinates of the points of interest. Must contain three 262 | #' columns with the x axis values, y axis values and z axis values of the points in the order x, y, z 263 | #' @param maplist list of data.frames which contain the points that make up the surfaces. The individual 264 | #' data.frames must have the same structure as \code{crdf} 265 | #' 266 | #' @return data.frame with the spatial coordinates of the points of interest and the respective position 267 | #' information 268 | #' 269 | #' @family posdecfuncs 270 | #' 271 | #' @examples 272 | #' df1 <- data.frame( 273 | #' x = rnorm(50), 274 | #' y = rnorm(50), 275 | #' z = rnorm(50) - 5 276 | #' ) 277 | #' 278 | #' df2 <- data.frame( 279 | #' x = rnorm(50), 280 | #' y = rnorm(50), 281 | #' z = rnorm(50) + 5 282 | #') 283 | #' 284 | #' lpoints <- list(df1, df2) 285 | #' 286 | #' maps <- kriglist(lpoints, lags = 3, model = "spherical") 287 | #' 288 | #' finds <- data.frame( 289 | #' x = c(0, 1, 0.5, 0.7), 290 | #' y = c(0.5, 0, 1, 0.7), 291 | #' z = c(-10, 10, 0, 2) 292 | #' ) 293 | #' 294 | #' posdec(finds, maps) 295 | #' 296 | #' @export 297 | posdec <- function(crdf, maplist) { 298 | .Call('_recexcavAAR_posdec', PACKAGE = 'recexcavAAR', crdf, maplist) 299 | } 300 | 301 | #' Multiple point position decision in relation to a set of stacked surfaces (3D) 302 | #' for multiple data.frames in a list 303 | #' 304 | #' \code{posdeclist} works as \code{\link{posdec}} but not just for a single data.frame 305 | #' with individual points but for a list of data.frames 306 | #' 307 | #' @param crdflist list of data.frames with the spatial coordinates of the points of 308 | #' interest (for details see \code{\link{posdec}}) 309 | #' @param maplist list of data.frames which contain the points that make up the surfaces 310 | #' 311 | #' @return list of data.frames with the spatial coordinates of the points of interest 312 | #' and the respective position information 313 | #' 314 | #' @family posdecfuncs 315 | #' 316 | #' @examples 317 | #' df1 <- data.frame( 318 | #' x = rnorm(50), 319 | #' y = rnorm(50), 320 | #' z = rnorm(50) - 5 321 | #' ) 322 | #' 323 | #' df2 <- data.frame( 324 | #' x = rnorm(50), 325 | #' y = rnorm(50), 326 | #' z = rnorm(50) + 5 327 | #') 328 | #' 329 | #' lpoints <- list(df1, df2) 330 | #' 331 | #' maps <- kriglist(lpoints, lags = 3, model = "spherical") 332 | #' 333 | #' hexadf1 <- data.frame( 334 | #' x = c(0, 1, 0, 4, 5, 5, 5, 5), 335 | #' y = c(1, 1, 4, 4, 1, 1, 4, 4), 336 | #' z = c(1, 5, 1, 6, 1, 5, 1, 3) 337 | #' ) 338 | #' 339 | #' hexadf2 <- data.frame( 340 | #' x = c(0, 1, 0, 4, 5, 5, 5, 5), 341 | #' y = c(1, 1, 4, 4, 1, 1, 4, 4), 342 | #' z = c(-1, -5, -1, -6, -1, -5, -1, -3) 343 | #' ) 344 | #' 345 | #' cx1 <- fillhexa(hexadf1, 0.1) 346 | #' cx2 <- fillhexa(hexadf2, 0.1) 347 | #' 348 | #' cubelist <- list(cx1, cx2) 349 | #' 350 | #' posdeclist(cubelist, maps) 351 | #' 352 | #' @export 353 | posdeclist <- function(crdflist, maplist) { 354 | .Call('_recexcavAAR_posdeclist', PACKAGE = 'recexcavAAR', crdflist, maplist) 355 | } 356 | 357 | #' Transformation of numeric matrices from wide to long format 358 | #' 359 | #' \code{spatiallong} transforms a set of two independent variables in vectors and a 360 | #' dependent variable in a wide matrix to a long matrix that combines the information. 361 | #' The result is exported as a data.frame. 362 | #' 363 | #' @param x vector of first independent variable. e.g. vector with x axis spatial points 364 | #' @param y vector of second independent variable. e.g. vector with y axis spatial points 365 | #' @param z matrix of dependent variable. e.g. matrix with z axis spatial points 366 | #' 367 | #' @return data.frame with three columns x, y and z 368 | #' 369 | #' @family transfuncs 370 | #' 371 | #' @examples 372 | #' x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 373 | #' y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 374 | #' z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 375 | #' 376 | #' sw <- spatialwide(x, y, z, digits = 3) 377 | #' 378 | #' spatiallong(sw$x, sw$y, sw$z) 379 | #' 380 | #' @export 381 | spatiallong <- function(x, y, z) { 382 | .Call('_recexcavAAR_spatiallong', PACKAGE = 'recexcavAAR', x, y, z) 383 | } 384 | 385 | #' Transformation of numeric matrices from long to wide format 386 | #' 387 | #' Transforms a set of two independent and one dependent variables in vectors from a long 388 | #' to a wide format and exports this result as a list 389 | #' 390 | #' @param x vector of first independent variable. e.g. vector with x-axis spatial points 391 | #' @param y vector of second independent variable. e.g. vector with y-axis spatial points 392 | #' @param z vector of dependent variable. e.g. vector with z-axis spatial points 393 | #' @param digits integer indicating the number of decimal places to be used for rounding 394 | #' the dependent variables \code{x} and \code{y}. 395 | #' 396 | #' @return List with three elements: 397 | #' 398 | #' $x: vector with ascendingly sorted, unique values of the first independent variable \code{x} 399 | #' 400 | #' $y: vector with ascendingly sorted, unique values of the second independent variable \code{y} 401 | #' 402 | #' $z: matrix with the values of z for the defined combinations of \code{x} (columns) and 403 | #' \code{y} (rows) 404 | #' 405 | #' @family transfuncs 406 | #' 407 | #' @examples 408 | #' x <- c(1, 1, 1, 2, 2, 2, 3, 3, 4) 409 | #' y <- c(1, 2, 3, 1, 2, 3, 1, 2, 3) 410 | #' z <- c(3, 4, 2, 3, NA, 5, 6, 3, 1) 411 | #' 412 | #' spatialwide(x, y, z, digits = 3) 413 | #' 414 | #' @export 415 | spatialwide <- function(x, y, z, digits) { 416 | .Call('_recexcavAAR_spatialwide', PACKAGE = 'recexcavAAR', x, y, z, digits) 417 | } 418 | 419 | #' Center determination for hexahedrons 420 | #' 421 | #' A hexahedron is a three dimensional shape that is defined by 6 faces and 8 corner points. 422 | #' \code{spitcenter} determines a center point for an input hexahedron by calculating the mean 423 | #' of the maximal extent on all three axis. 424 | #' 425 | #' @param hex dataframe with three columns and eight rows to define a hexahedron by its corner 426 | #' point coordinates x, y and z 427 | #' 428 | #' @return vector with the spatial coordinates of the center point of the input hexahedron 429 | #' 430 | #' @family centerdetfuncs 431 | #' 432 | #' @examples 433 | #' hexatestdf <- data.frame( 434 | #' x = c(0,1,0,4,5,5,5,5), 435 | #' y = c(1,1,4,4,1,1,4,4), 436 | #' z = c(4,8,4,9,4,8,4,6) 437 | #' ) 438 | #' 439 | #' center <- spitcenter(hexatestdf) 440 | #' 441 | #' #library(rgl) 442 | #' #plot3d( 443 | #' # hexatestdf$x, hexatestdf$y, hexatestdf$z, 444 | #' # type = "p", 445 | #' # xlab = "x", ylab = "y", zlab = "z" 446 | #' #) 447 | #' #plot3d( 448 | #' # center[1], center[2], center[3], 449 | #' # type = "p", 450 | #' # col = "red", 451 | #' # add = TRUE 452 | #' #) 453 | #' 454 | #' @export 455 | spitcenter <- function(hex) { 456 | .Call('_recexcavAAR_spitcenter', PACKAGE = 'recexcavAAR', hex) 457 | } 458 | 459 | #' Center determination for rectangles whose tops and bottoms are defined by irregular surfaces (3D) 460 | #' 461 | #' \code{spitcenternat} first of all calculates the horizontal center of an input rectangle. 462 | #' Then it determines the vertical positions of the center points in relation to a surface stack. 463 | #' 464 | #' @param hex data.frame with the 2D corners of the rectangle defined by four points 465 | #' @param maplist list of data.frames which contain the points that make up the surfaces 466 | #' 467 | #' @return data.frame with the spatial coordinates of the center points 468 | #' 469 | #' @family centerdetfuncs 470 | #' 471 | #' @examples 472 | #' df1 <- data.frame( 473 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 474 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 475 | #' z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 476 | #' ) 477 | #' 478 | #' df2 <- data.frame( 479 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 480 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 481 | #' z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 482 | #' ) 483 | #' 484 | #' df3 <- data.frame( 485 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 486 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 487 | #' z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 488 | #' ) 489 | #' 490 | #' lpoints <- list(df1, df2, df3) 491 | #' 492 | #' maps <- kriglist(lpoints, lags = 3, model = "spherical") 493 | #' 494 | #' hexatestdf <- data.frame( 495 | #' x = c(1, 1, 1, 1, 2, 2, 2, 2), 496 | #' y = c(0, 1, 0, 1, 0, 1, 0, 1) 497 | #' ) 498 | #' 499 | #' spitcenternat(hexatestdf, maps) 500 | #' 501 | #' @export 502 | spitcenternat <- function(hex, maplist) { 503 | .Call('_recexcavAAR_spitcenternat', PACKAGE = 'recexcavAAR', hex, maplist) 504 | } 505 | 506 | #' Center determination for rectangles whose tops and bottoms are defined by irregular 507 | #' surfaces (3D) for multiple data.frames in a list 508 | #' 509 | #' \code{spitcenternatlist} works as \code{\link{spitcenternat}} but not just for a 510 | #' single data.frame but for a list of data.frames 511 | #' 512 | #' @param hexlist list of data.frames with the 2D corners of the rectangles 513 | #' @param maplist list of data.frames which contain the points that make up the surfaces 514 | #' 515 | #' @return list of data.frames with the spatial coordinates of the center points 516 | #' 517 | #' @family centerdetfuncs 518 | #' 519 | #' @examples 520 | #' df1 <- data.frame( 521 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 522 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 523 | #' z = c(0.9+0.05*rnorm(6), 0.9+0.05*rnorm(14), 1.3+0.05*rnorm(14), 1.2+0.05*rnorm(6)) 524 | #' ) 525 | #' 526 | #' df2 <- data.frame( 527 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 528 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 529 | #' z = c(0.6+0.05*rnorm(6), 0.6+0.05*rnorm(14), 1.0+0.05*rnorm(14), 0.9+0.05*rnorm(6)) 530 | #' ) 531 | #' 532 | #' df3 <- data.frame( 533 | #' x = c(rep(0, 6), seq(0.2, 2.8, 0.2), seq(0.2, 2.8, 0.2), rep(3,6)), 534 | #' y = c(seq(0, 1, 0.2), rep(0, 14), rep(1, 14), seq(0, 1, 0.2)), 535 | #' z = c(0.3+0.05*rnorm(6), 0.3+0.05*rnorm(14), 0.7+0.05*rnorm(14), 0.6+0.05*rnorm(6)) 536 | #' ) 537 | #' 538 | #' lpoints <- list(df1, df2, df3) 539 | #' 540 | #' maps <- kriglist(lpoints, lags = 3, model = "spherical") 541 | #' 542 | #' hexatestdf1 <- data.frame( 543 | #' x = c(1, 1, 1, 1, 2, 2, 2, 2), 544 | #' y = c(0, 1, 0, 1, 0, 1, 0, 1) 545 | #' ) 546 | #' 547 | #' hexatestdf2 <- data.frame( 548 | #' x = c(0, 0, 0, 0, 1, 1, 1, 1), 549 | #' y = c(0, 1, 0, 1, 0, 1, 0, 1) 550 | #' ) 551 | #' 552 | #' hexs <- list(hexatestdf1, hexatestdf2) 553 | #' 554 | #' spitcenternatlist(hexs, maps) 555 | #' 556 | #' @export 557 | spitcenternatlist <- function(hexlist, maplist) { 558 | .Call('_recexcavAAR_spitcenternatlist', PACKAGE = 'recexcavAAR', hexlist, maplist) 559 | } 560 | 561 | --------------------------------------------------------------------------------