From 069bcaaff92751b51d0423f7be9c7fa517f55bfa Mon Sep 17 00:00:00 2001 From: romunov Date: Sun, 16 Dec 2018 18:00:04 +0100 Subject: [PATCH 1/2] Data source switched to SQLite database --- DESCRIPTION | 5 +- R/base_body.R | 16 ------- R/file_input.R | 86 ++++++++++++---------------------- R/ui_render_floating_inputs.R | 2 +- README.Rmd | 32 +++++++++++++ README.md | 34 +++++++++++++- app.R | 18 +++++-- db/wolfexplorer.sqlite | Bin 0 -> 28672 bytes db_setup.R | 36 ++++++++++++++ 9 files changed, 149 insertions(+), 80 deletions(-) create mode 100644 db/wolfexplorer.sqlite create mode 100644 db_setup.R diff --git a/DESCRIPTION b/DESCRIPTION index 9b8b681..bcbd4b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,8 +12,9 @@ Imports: tidyr (>= 0.8.0), plyr (>= 1.8.4), rgeos (>= 0.3-26), - kinship2 (>= 1.6.4) -version: 0.9 + kinship2 (>= 1.6.4), + RSQLite (>= 2.1.0) +version: 1.0 Authors: Roman Luštrik (@romunov) & Žan Kuralt (@zkuralt) License: GNU GENERAL PUBLIC LICENSE DisplayMode: Normal diff --git a/R/base_body.R b/R/base_body.R index c86d272..ed65b57 100644 --- a/R/base_body.R +++ b/R/base_body.R @@ -25,25 +25,9 @@ body <- dashboardBody( ) ), tabItem(tabName = "data_samples", - fluidRow( - box(solidHeader = TRUE, collapsible = TRUE, title = "Upload samples data", - fileInput(inputId = "data_samples", - label = "Upload dataset", - buttonLabel = "Select data", - accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv"))), - h4("Upload parentage data for full functionality")), - br(), - br(), uiOutput("view_samples") ), tabItem(tabName = "data_parentage", - box(solidHeader = TRUE, collapsible = TRUE, title = "Upload parentage / colony data", - fileInput(inputId = "data_parentage", - label = "Upload dataset", - buttonLabel = "Select data", - accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv"))), - br(), - br(), uiOutput("view_parentage") ), tabItem(tabName = "overview", diff --git a/R/file_input.R b/R/file_input.R index 5812592..1d1d5d7 100644 --- a/R/file_input.R +++ b/R/file_input.R @@ -1,62 +1,36 @@ inputFileSamples <- reactive({ - x <- input$data_samples - if (is.null(x)) { - data.frame(lng = NA, lat = NA, date = NA, sample_type = NA, animal = NA, sex = NA, - sample_name = NA, id = NA, reference_sample = NA)[0, ] - } else { - x <- tryCatch(fread(x$datapath, - encoding = "UTF-8", - colClasses = c("numeric", "numeric", "character", "character", "character", - "character", "character", "character"), - data.table = FALSE), - error = function(e) e, - warning = function(w) w - ) - - if (any(class(x) %in% c("simpleWarning", "simpleError"))) { - alert("Input data not formatted properly. Please compare your input file to the specs.") - x <- data.frame(lng = NA, lat = NA, date = NA, sample_type = NA, animal = NA, sex = NA, - sample_name = NA, id = NA, reference_sample = NA)[0, ] - return(x) - } - - validate( - need(all(colnames(x) %in% c("x", "y", "date", "sample_type", "animal", "sex", "sample_name", - "reference_sample")), - "Column names not as expected.") - ) - - x <- GKtoWGS(x) - x$date <- as.Date(x$date, format = "%Y-%m-%d") - x$id <- 1:nrow(x) - - x + xy <- dbReadTable(conn = db, "samples") + # x y date sample_type animal sex sample_name reference_sample + # 1 415290.5 48492.58 2010-04-23 Saliva 657 M AH.03MT AH.03MT + # 2 439351.3 44444.31 2014-12-22 Saliva 657 M EX.1JKT AH.03MT + # 3 445348.9 44420.60 2014-12-15 Saliva 658 M EX.1JJ1 AL.05PH + + validate( + need(all(colnames(xy) %in% c("x", "y", "date", "sample_type", "animal", "sex", + "sample_name", "reference_sample")), + "Column names not as expected.") + ) + + if (nrow(xy) > 0) { + xy <- GKtoWGS(xy) + xy$date <- as.Date(xy$date, format = "%Y-%m-%d") # sqlite can't handle dates properly + xy$id <- 1:nrow(xy) } + + xy }) inputFileParentage <- reactive({ - x <- input$data_parentage - if (is.null(x)) { - data.frame(offspring = NA, mother = NA, father = NA, cluster = NA)[0, ] - } else { - out <- tryCatch(fread(x$datapath, encoding = "UTF-8", - colClasses = c("character", "character", "character", "character"), - data.table = FALSE), - error = function(e) e, - warning = function(w) w - ) - - if (any(class(out) %in% c("simpleWarning", "simpleError"))) { - alert("Input data not formatted properly. Please compare your input file to the specs.") - out <- data.frame(offspring = NA, mother = NA, father = NA, cluster = NA)[0, ] - return(out) - } - - # if column names do not match predefined form, warn user - validate( - need(all(colnames(out) %in% c("offspring", "mother", "father", "cluster")), - "Column names not as expected.") - ) - return(out) - } + xy <- dbReadTable(conn = db, "parentage") + # offspring mother father cluster + # 1 M2122 AU.0AEF AH.03MT 2 + # 2 M0PLL #1 M1J4C 2 + # 3 M110M #2 *3 3 + # 4 M1H52 M1HXJ AL.0611 2 + validate( + need(all(colnames(xy) %in% c("offspring", "mother", "father", "cluster")), + "Column names not as expected.") + ) + + xy }) diff --git a/R/ui_render_floating_inputs.R b/R/ui_render_floating_inputs.R index 2509c2a..47004b8 100644 --- a/R/ui_render_floating_inputs.R +++ b/R/ui_render_floating_inputs.R @@ -1,7 +1,7 @@ # Render floating inputs which control selection on the map. observe({ output$menu_data <- renderMenu({ - menuItem("Load data", tabName = "upload", icon = icon("paw"), startExpanded = TRUE, + menuItem("View data", tabName = "view_data", icon = icon("paw"), startExpanded = TRUE, menuSubItem(text = "Samples data", tabName = "data_samples"), menuSubItem(text = "Parentage data", tabName = "data_parentage")) }) diff --git a/README.Rmd b/README.Rmd index c2eefba..67227af 100644 --- a/README.Rmd +++ b/README.Rmd @@ -8,6 +8,38 @@ output: Explorer designed to visualize complex multi-year multi-specimen data. Attached data is a subset of data from wolf monitoring of wolves in Slovenia in season 2016/2017 ([summary in English](http://www.natura2000.si/uploads/tx_library/MonitoringVolk__summary.pdf)). +### Setting up the SQLite database +_Do not panic, it's not as hard as it initially seems._ In version 0.9, the data had to be uploaded manually for each session. From this point on, an sqlite database has been established to keep the data persistent between sessions. In order to fully take advantage of the database, you will need to import your data into a database called `./db/wolfexplorer.sqlite`. If you wish to change the name of the database, you will have to account for this in `app.R` to point to the correct database file. + +The database holds two tables, `samples` and `parentage`. This are their structures: + +``` +db <- dbConnect(RSQLite::SQLite(), "./db/wolfexplorer.sqlite") +# table: samples +str(dbReadTable(db, "samples")) + +'data.frame': 214 obs. of 8 variables: + $ x : num 415290 439351 445349 446926 447214 ... + $ y : num 48493 44444 44421 49001 48825 ... + $ date : chr "2010-04-23" "2014-12-22" "2014-12-15" "2015-07-10" ... + $ sample_type : chr "Saliva" "Saliva" "Saliva" "Saliva" ... + $ animal : chr "657" "657" "658" "658" ... + $ sex : chr "M" "M" "M" "M" ... + $ sample_name : chr "AH.03MT" "EX.1JKT" "EX.1JJ1" "EX.1JL4" ... + $ reference_sample: chr "AH.03MT" "AH.03MT" "AL.05PH" "AL.05PH" ... + +# table: parentage +str(dbReadTable(db, "parentage")) + +'data.frame': 40 obs. of 4 variables: + $ offspring: chr "M2122" "M0PLL" "M110M" "M1H52" ... + $ mother : chr "AU.0AEF" "#1" "#2" "M1HXJ" ... + $ father : chr "AH.03MT" "M1J4C" "*3" "AL.0611" ... + $ cluster : int 2 2 3 2 2 2 2 3 2 2 ... +``` + +If you do not care for manual setting up the database and have the files already handy, there's a handy script called `db_setup.R` in the base folder of this application. The script imports the data which is shipped with this package. It will help you import two data.frames into a database. You will have to name your files to match those expected by the script or modify the script to reflect your file names. Note that the script makes no attempts to clear any databases. If it is already populated, you will either have to purge the database or use `append` or `overwrite` parameters. + ### Limitations This viewer will require you shape your data to a somewhat specific, yet general enough, format. It can display only certain coordinate systems. Luckily WGS 84 (EPSG: 4326) is one of them. Data in the application is not persistent, but this limitation is something we're thinking of relaxing in the future. diff --git a/README.md b/README.md index 76f43e9..ea08452 100644 --- a/README.md +++ b/README.md @@ -8,6 +8,38 @@ output: Explorer designed to visualize complex multi-year multi-specimen data. Attached data is a subset of data from wolf monitoring of wolves in Slovenia in season 2016/2017 ([summary in English](http://www.natura2000.si/uploads/tx_library/MonitoringVolk__summary.pdf)). +### Setting up the SQLite database +_Do not panic, it's not as hard as it initially seems._ In version 0.9, the data had to be uploaded manually for each session. From this point on, an sqlite database has been established to keep the data persistent between sessions. In order to fully take advantage of the database, you will need to import your data into a database called `./db/wolfexplorer.sqlite`. If you wish to change the name of the database, you will have to account for this in `app.R` to point to the correct database file. + +The database holds two tables, `samples` and `parentage`. This are their structures: + +``` +db <- dbConnect(RSQLite::SQLite(), "./db/wolfexplorer.sqlite") +# table: samples +str(dbReadTable(db, "samples")) + +'data.frame': 214 obs. of 8 variables: + $ x : num 415290 439351 445349 446926 447214 ... + $ y : num 48493 44444 44421 49001 48825 ... + $ date : chr "2010-04-23" "2014-12-22" "2014-12-15" "2015-07-10" ... + $ sample_type : chr "Saliva" "Saliva" "Saliva" "Saliva" ... + $ animal : chr "657" "657" "658" "658" ... + $ sex : chr "M" "M" "M" "M" ... + $ sample_name : chr "AH.03MT" "EX.1JKT" "EX.1JJ1" "EX.1JL4" ... + $ reference_sample: chr "AH.03MT" "AH.03MT" "AL.05PH" "AL.05PH" ... + +# table: parentage +str(dbReadTable(db, "parentage")) + +'data.frame': 40 obs. of 4 variables: + $ offspring: chr "M2122" "M0PLL" "M110M" "M1H52" ... + $ mother : chr "AU.0AEF" "#1" "#2" "M1HXJ" ... + $ father : chr "AH.03MT" "M1J4C" "*3" "AL.0611" ... + $ cluster : int 2 2 3 2 2 2 2 3 2 2 ... +``` + +If you do not care for manual setting up the database and have the files already handy, there's a handy script called `db_setup.R` in the base folder of this application. The script imports the data which is shipped with this package. It will help you import two data.frames into a database. You will have to name your files to match those expected by the script or modify the script to reflect your file names. Note that the script makes no attempts to clear any databases. If it is already populated, you will either have to purge the database or use `append` or `overwrite` parameters. + ### Limitations This viewer will require you shape your data to a somewhat specific, yet general enough, format. It can display only certain coordinate systems. Luckily WGS 84 (EPSG: 4326) is one of them. Data in the application is not persistent, but this limitation is something we're thinking of relaxing in the future. @@ -34,7 +66,7 @@ shiny::runGitHub(repo = "wolfexplorer", username = "romunov") `*` you can install packages listed in the [`app.R`](https://github.com/romunov/wolfexplorer/blob/master/app.R#L1) using something along the lines of ``` -install.packages(c("shinydashboard", "leaflet", "RColorBrewer", "DT", "sp", "rgdal", "data.table", "ggplot2", "colourpicker", "tidyr", "plyr", "rgeos", "kinship2")) +install.packages(c("shinydashboard", "leaflet", "RColorBrewer", "DT", "sp", "rgdal", "data.table", "ggplot2", "colourpicker", "tidyr", "plyr", "rgeos", "kinship2", "RSQLite")) ``` ## The manual way diff --git a/app.R b/app.R index 77bd01b..1c3ec9b 100644 --- a/app.R +++ b/app.R @@ -11,6 +11,17 @@ library(tidyr) library(plyr) library(rgeos) library(kinship2) +library(RSQLite) +library(pool) + +# Make connection to a database and tear it down on stop. +db <- dbPool(drv = RSQLite::SQLite(), + dbname = "./db/wolfexplorer.sqlite" +) + +onStop(function() { + poolClose(db) +}) source("./R/functions.R") @@ -27,7 +38,7 @@ ui <- dashboardPage(header, sidebar, body, skin = "black") #### SERVER #### -server <- function(input, output) { +server <- function(input, output, session) { #### FILE INPUT #### source("./R/file_input.R", local = TRUE) @@ -35,7 +46,7 @@ server <- function(input, output) { #### CREATE VARIABLES #### source("./R/create_variables.R", local = TRUE) - #### VIEW UPLOADED DATA #### + #### VIEW DATA #### source("./R/view_data.R", local = TRUE) #### DYNAMIC UI #### @@ -46,7 +57,6 @@ server <- function(input, output) { #### PLOT PEDIGREE #### source("./R/plot_pedigree.R", local = TRUE) - -} +} shinyApp(ui, server) diff --git a/db/wolfexplorer.sqlite b/db/wolfexplorer.sqlite new file mode 100644 index 0000000000000000000000000000000000000000..a127cf612842f286e8050d7375deccbcdb42d436 GIT binary patch literal 28672 zcmeI4d3;kv*ZA9{`;vexX`8mR>;f&>Zf??oPN*%VZ6H7jDJW2AfwD{41tFj!Dj)*N zBFGLdpa}YiiX!_CzM|rz>|HEfDWxcayywi!O|Izg`Fwu=z3=-8pU0a%ZNEJ;XU?3N zIdjhK-#4ddN@2ptiId0YPf0NPHSzQJ_ag}jetv!d@Lw?eC;bb8FYtTPKY!_q|L_^$ zmmK?1B>aLxwbxIzSKaMD{I2guJ`MOZ;M0Il13nG-G~m;KPXj&;_%z_tfKLNH4g5s| z?m$Jbrd2C{cixoz;o}M?>DHVANj_JaZ`(@;IH)R?M&~P-Y@KNw@n$W z(Q5tYvvw5ckDoNIu$X@+{@MoqUEYEj!xEr{IaKmY+1Ca6Qwn8mV9?MhGbhQvn?Ipw zeEvB3uNA`I^Yny66Y|H)p~;0K3qegI3Wu_vGa&5oK+vpGU5olvs{c^mQP--Ls|Kp# zBCkhokDL@KMBIz`I^yMs-Vx2iFNJRlpAasFJq$Y@_F7oqu;!sZhOP-67TP|fI%H4C z^pGb)0)tNnFAp9RoDftN^g+<%AZw6c;IY6Zfw_Uv0ha?d1&j_zR@N&&RX(RA%0R_Q z#bSj+(aiq`|JD9a`?vBd@!S5FVV3`&)U?px;Kb-=YOU55`(r>*K~g-a%gYV_?UJ8C zr#B_(tVw#YfBv|lY58WW)t;W7tT)+mY_4Qonlr=N1K}17p0xYB7OD=Uy3^H~A-DYj zHYDNybp1!gz&5=EKPiLH?)h?Z#}HChUG(v}u7MJ)w>}CR zCHM&$e4^9P>9>cHvInVKevf@1!8%D@QnS-NaCa{pd*N~GaaAg*yj-dxl_^Q?CWF5_e`tTrH>7gyk4^l$DkWHNc?8Z(li*Y@95>?0jOPXikjj(0iz9oY z!eEreB%|&T*q+W|YYM__l;grThmN%GCslI?8h^E*!T^R*7U?Ksk28|>g2O4HRvEhE z;4<6w&7?AV{E|)|p}O>l>MRn<840y`(b$g7Ccdn>OiI%Grm4#A1FGZ7Lff*KGLW&^ zZT!P3deP{AP1*Q?@Fyu(tXx%NM--%*lMGfWRkSiRUHV8dBdTE*z5a>bXO6u{O4q!* zFC+0DlPV_ZEj`9foLFEML99JlCuZ3BM~dKOQ&A^u_2Bg<`~*&k!4)NdhGtLD!NPz3`ErVO~5s@N>rnN4I-R41nBykg_} z<^&yhb2_QCE#0_k1e%i(bOgQS4HlVLoyb|SD;EoD($1_cyZ6cl(h%(apv@Bs)>)I} zaLh)~QijWhppcsg0X(R!biNFM(W?`zfG&0$3SC}USJx+rsieP0Y$L07u2q;Kfn6% zGE$S(uYH%#(TqT%$Eji;4LY6FM@uIJ!FEwO`koWbb8e7^wZq;|obfyZ!G^3{u~cN9 z)K<&mGSYZ@=D-1^q~XP5F{$&p$iI=9Ts@YKGIGh(u!z@Jk=vD@eKo4cE7RbWY0w$z zh(b3l9c1LjmmbT1`Uttba$={WA$%x7=3mJiX-L{53ATs*9NT@{rQ{)`;hioM=Oq3K z{WQ~g#%+%($SgHhY$pRpzWx36o+C-ah3MoxZE#4;RI_@|kmwu^kHoezu?-GLd6K_Ac5xh*T^X{&KJV9?cpgXMm(WJ5M6xWTbPW zd(?%WNY$WgcZxN*9>QRP{m4m!;NWCxERt-?6aB}H-q)vRl3K&2$t4}Jv1}QZ7DKba zPPZO8T)&P~tqgw9ck-QcTS-m$_l2wf;QJO!l4tiI!P$IjJ5pn0@J&CzvAYvU&5)U= zrqAPRIOtf~dU#+RZ?-iWVdipUOqRvn*5#4fbqDH&ATAkJHEx8^Xk3P!l9p4V5amYU z>fNzRuY088(1f<%6#On3gK+Gb}MFH6W7bOt@;gcdS!UEPz?=f#k! z21l=fS>EN0xlM){xwz&safUY*oX;CXs)MEt&S`~X3O)fQ8uxvS%gkirnt8>=hur$% zk0YB%xzqCV#P3iXaIkE%2}&`8DUD%|d9k?Ug%0C|!=$RH`z+xo6NfuFw((`sV2glC zu{7na)Phoul+GC1A(m9MEsSr-^4P4jRs%-|z>&qsCNlEev92eCVWeVh+ZAtK#Qg!a z_P>$otf^{QQ=5D;DSGK}arKCCLlaFRe%Pi(s~IyZ%s zN9;Rve=j#xD>@){E&z~Dl5`70BW38>Bj0`fENrkVheV!l=8^a}G%c5*5i<0&`rBJ? z%_U_&>sP%R<=NQ(9d%Ju2>13g_It&+_-lhnAQ>jSXz_v$G*FtavEm_^CORDP&E<8X({oEP7E39#KWfZJu(keL$9NjR@*-Gcv1iO-YDg-u%}*Lw^> zXJJzrNCwf}liWg52y+e|c=) zEK>es^TluFqoan-!p2x~ngBDW>45`ea8L1tU8h%(^6DRI8FlNsqLetm?Ar9n~;ZV&t#B^FM?ReCL1P`QLZ`_nrTJ=YM*F^PT^F z=YQD7`p*Bp^FQB>`p*BhIN$kS@SXqvhoAq=?g4m8Y|%muk*=7pOYSy)bCuj))M}|a z49}-#~rwv+)ghZ^J(j+7S38tY6?HLEu~jR5b4F}l?R6lC**S2 zU&*m|bNBb++9y9*+G1)HDUFUU_<9Tr6w_n12iJ2vi~W_XRChm$(~B}~%L|(GIr~X< z$A*`)*JFGS8V~Uyez3L}AP|8U#u+yLA-el=8gv#Nu1M|iL@a6iua#fiy~m#uoLUp=L?K0n)h0HhSJs)HX!aAz()%ZN#a_5BN@u8aMDTnvXG_J@vd$xsgqPsWeAPyE)*Lm>Ekyl9L*wZUNG~p!~ z#656;F?@y`yXX=riRb?`xOi6|Qop3`rH)XY^WFbr&VcX!pIt8d?*D!F|GxWw-~B(k z!S$X0edmAQ`QLZ{@4Nr^-T%`JLErsCE|NkrQ{{=`@WmyCK1JD2IenygOISnLmtil2 z*Do!buEAkYr{7e1c_b>Lh!n+5KLWBOl|5@C2jDKM2n8v2< zQoQBC8>2|YaQ7#BR%4I~Q+1_0E)0NR%7)n}@Q_Q6H{_yioHz2p@f1?OB5TZs5=0>d zOv-?@Kv)Yh$1+TI$PdjG-Py=N>Jfx^w9|He@Y%Muq#>YLeDZXjaRyR(X#gj)%#;+| zSu%;Em;Dr0zlk)=4!v$zHjhcfoIo0^L5V1gOY9|+IN_Y~)J}iWFy-8!uiIjfhbF5@ zNqtp%>jfWn{blGuu_X zNa_ObKR)D!Hw4BLY9!LY$qX6U%J16Xf-gy3+@9X|C$elB44yqgLhuY^3hs0yS@0~T zKsoQ-7dw)g-q+7(4nvYB<+F2T^~C&zm>|F%7;DZMrDWCh9tPDnEF2&ZVZ0;vZZ!iV6NDofA? zW{o&@HE1=dzPdQ^Oe;(TqY`yAT*o+rIh%8|tc3MYn|A6%;u1Hh-rRB4TZb?&{U108 z^HF)UqJ(qSb*2lki%9k7uk|~yjR$eT=D0iywlhaZAA*|}lW;C)z^SFXW{|4NpKGRS zJerYn26H;)%x+pof(c;IzX_?||9%8gv1*=K7W=6u@0Dj{idHmLeYTT6%x+pk!oi|M zzYQVnNmW;O{D`x>p_mOt^S>kzY#eCOE!B_USP1)0Hs{#r zqd+JV0dGSE(kc;2;H!80H1Q*iFU~!oPREAAO@V=5Qb--dF~kni8WF}tw`!hn{Mrt3 z*OE5va3VJJ@0`)aIjKGbMk2QJp=0B}g%PZOY40mjJc{A-!eY#Tb~=spA-HLA2$QEh z?%(8a(hgGj+?}~k&u2D+S$Aw6B4^NL37qp3hJd`BsmEH={zNL{_a3|2jr*BLxXe7tiEdgJ!fZQc^R;*0a>kIFsdxN; zZifk+Fc6s7&n_@Tk>*9)v77b`!R@IF0UMovePEk$`$$=8o6cu0dRI4^k1L9F1hcY% z%gPqqp0W^}6Rk%-(`^>13O%vvU!U^T6biBE+9rxLH$M|sD4j)c)2a}zQTKq;TPJ6d z>hCZ7R2$$K36|kZIYcNYx@k=a>tWoAmcM^-a4@N8@<#FdAM&{b$&-3^S1pRLTEO}Z zHlx!y1vjk;VG?6Ydd=Ox@;6dD_~@p{0#6wMtfn|AkVAxXv?7FYtqk`+JFzv7Tz}zg zP^VzdfkZZY&9GL0JV>g}bETWzv>t@b-uQA|LF#+kNU6E%?V|HMWgKjqyF>=MAoUkO z(M{_?_#isEHMt7TyH>OQmB*govkE+;8P$D=w1yoi7H}Z=KILX-g!U&9sX!eRVp! z;P#Y*z~J{@JYlPT2f5QSZcVnG8;!I8Qw|Z%(P|Jr`001MRED=FclP(l-ta10fMMDj znbDv;@S(7bQhBrzgmZ=&N?YCx(lBrJ59{*L&#-AvZ`oKoU4q1U>Oi1>uJ-Fg3tu2L z-J9F@I=JJexw<&?w12J)*eX(avqT`r*!sKmvJL&cd^+Jn4 zICtV!+v|aeG{d%w_K%i(FnO&q#M8MYbI7%|9Tu%E=i@F)_9CEb$`)WU z!9#G%%009{jk!1Go{iin`|e=s-AA`FaNlm%XJNSqJOsC_-Xms&!mrOV3n{5nRM*z< ztb1_2tbZoh9_lk)P_+RM(M=0JxQFqpZMgkX0V$t!xM}B>I1aS_ODftGku(?$;O>DG z+_d0>^-z0Z%g1jwv5}JI`}S@51bfIl46`&79-cC@plkykqMMd`aEZI-Up%pJHmQwk z5|wrnM-U`}g<7~zGnsKOql1M49)g=zd@zYIQFje_`=PSwO4#pNv@Vmj)xgFcIen%G zZkuwn+=Fu?50AgG<{47@bg!Z#-MP(pb%Vo@DH!NOaMM~3&J}&N`s&&zNXhY4)0z?H zn;>sO(kaftOc#trhCNqs%L+YW6fb-laA*iA@3*8?@F|?TOsCAYO~?VlIa=w#Fb}V#km9=WDfBDQF-aGN>F*U%!6^UdCpZs-`heOqBpJB9M62A&WPJs z^l2tsc*QIyeX#TYEH>HBMKrqhu4Si z3!fL>Gdv>fT-b`Rys*}x<)I&h7Kf&UJP0`)@@h!Gkm%sc!JC7}1RI0y!|8uX(7>RC zz|z27fztz@3=9f56R&U6)bKhe#5jRl0m!K8B9#$B92yR-B!Z_`wwkxOSj3yQ3 z@4R_U!Dp~%Wdh%1*E^lCVRPnyebZVL&VBuTx;`P4R2*46=^1*cV57+7F)jyY6y<0g z3g=G#>DU*3joiHTo@-jFr??2VB{&+C(`CXaQjV6OaL!-5$8sQ*)K_d8u<^Dbtafk@DSWI`oy@HkZVoLrzuFy_B{94lb#iZ6=G6O=g2d2juxIs{R>$1 z%Gp>_(qj1a?PpkB5gcLoN@0XUfzFYWLmz^h)|_y8#$OA%CPa}xM=w}=s&oZdDfRe# z#fCrvAlWwL;K1zXJ)*}rXKej8?;?4ax^dOi<#iIrJt=Z9Zyk)AE5lqjro6W2EAnu} zvt_%x{Yo+KzL{Z}xeR+=hRq#0>DLtx$-}lOlfJmu$S`9P_Z5igUB+yN&GBMd`}G$~ z%kxQvYUt)pO1?{nQ#NyIRGI;zG_-TGWmtOR&7Q3bN%fPad&fi2#$YvrRYH!LGa2@r z7mK-YqHxHJ0#e(<{rWH8c#5p}jv1w)AcoD7VL?+aPkZt*sUKVUaTVcy0!EGtR?E3|sAB43f^~dkV zY1T1+?HvG)Vc$U7bQxB1Y2d$>wjuQcdmp_213FK-@qtQGoCdU!cBhVF=4puW=)u?N zKbihLf>hSU6xs^Vn!&oTZ|wYNpb;|Ip+oe*B~C?-tt#55ZXJ2E`D#*r_SRg*Ahr*| z{RFQD6d9NfM{5M9c)^&)*=?_#XiX}nuA3JZ&lgVE`0!U=Fwh`CEDu0)v8<)DcAb5( z?;KLK&Zr!FknJQfbHKM$|QD)Oxc&(gVaV0Jv2IpEn}!sX4JHy*=excVnZj$u-rBK?|u9W zsm_}^*ItGSg?#~J8}k0)3Bm~(f3U;O5XQ@}Hb+0~5p<2z{F2k{Mh@Rjz=UP))<6#) znXo}aY@7^BQ9AmcT2E?2>q-ipo?|XQ=TOY$$Ya=888&8eWwm-cscE;KeE%9huHeCn zSto5|F2-*`+87yT`aWh&<7HCYzjF2N?HIhHdmd@*=xGIGjev4ip{bMPp{(^y|9?UYql3w+|L}b~6+P-ZLRMnyF*W9VzuvYm3`iJna56(WG>( zwcTfJJtHWY8mtWZJY5>56`D~%oC)_{Ac^UsoV|1A&G5Z3^Xcc&y>Id z8K^EAp8ruisoJqfN50@YEtvIe_ew#7nIswU3fikIr8ENi%FJEYhBB zJq3+skxNV+jvx#PzE$X_XWPs;y@pg~&9O!Nz%}cAyN?Jc)vP5;YHq$v>e*F4rp$7Y zDpT=WuS9r;g;nw*YS%jql2mb+7mVwgIQ39IfX?Be=Z5pO8m1I?iU?-gvbjX-P!2+K zbT~we5mvz8?X9!>2Jr z1&4{F!ZT8H;ZXnX!->C4+d;}2W6u5dE+!_)GTu7ZPWa zx;|n5(vHBoPnase>e`Q2(2hX1=rYASqqn#&K>rR}uIfUWF^_jBG@+X})i|F2|bZl^dH< zJoaSi26F96`&0LRLth6*1or^!_zNf|hyueuL>EWlofI)mQtFC6Ur%m*aIIv+5!`(< zf5%RUI(lVcvCst5T$4D^3r08IU$%gBBlWHKzCF{;gFDb*F9_3&z0?Xomd{OJFB1Jn z=UuypwkGu*-@dqG?t*`i2w`N*zmX29mo#;oH8v*d@`H{S zwvhVDZuhsYoX2Fsiq5(ST3_78$JZ0({Fa}4PcDCKUWdbS*D?nqxtZV#*ZsMmNL z5CA=U0Sf8`K?3QeCm)bYuls$m58mB#eel`3$!K&etiBFX@8%X{7$}(eVgQ4@z%6K_;T7F1#B5@>)_ipv~p3`*~ykj!I)` zrPrPuJ^lMT?<{Xe>aq|1q#NsXn4W$zsXD2_^xjiKKPoxdZ8WJHe665t*Z&K3xFnQb zd@@vPKGjJd;YTX;E!t2122r$F=^Oysz8+Z| zIVjQ=*)g(N#BULoB92Dvj93vdCt_SgfB1vGe?ATPG~m;KPXj&;_%z_tfKLNH4fr(h ze@g?+I|gdBP5tqLmA(8PGCNBSP^ z`2mL5y?;&<1wFy$Li!c{6$nbf&$C?$jfVXI6zk-%JP1QNO-fBm-ej6+0s%KqlUwi~ z(A#LZ-{);qXqvMh(Ay`u@RrS>FHQaFAILTF7h8i3w0w+xpS>H8SL1iGDl|>G1bY80 z6RmE-Yy%reZKI_+P}>x=gnDsiv@!Ab2`HMYpjT)_kV(nkXx&LrXd*p*P5X-yT10?A zsvXGPLk4x@RI~_}zU^S)Zf<#Dym@%BD(|Nzl>LAisZ9IY5IUG#zmFJM^I+Ci3~G9H zqY2`FizXn;{#JA#{5qH`W_>+klbQhDFqW6#9T~Nf>kV$Xsoow_z&D`7FjP5hz<9xk V7193e57QpuJILWh;;afl@!zajYo7oB literal 0 HcmV?d00001 diff --git a/db_setup.R b/db_setup.R new file mode 100644 index 0000000..5f5edb3 --- /dev/null +++ b/db_setup.R @@ -0,0 +1,36 @@ +library(RSQLite) + +db <- dbConnect(RSQLite::SQLite(), './db/wolfexplorer.sqlite') + +data.sample <- "./data/sample_wolf_data.txt" +data.parentage <- "./data/sample_wolf_parentage.txt" + +if (file.exists(data.sample)) { + # TODO: We may want to implement some sanity checks (e.g. check proper column names, types). + smp <- read.table(data.sample, header = TRUE, sep = ",") + dbWriteTable(conn = db, name = "samples", smp) +} else { + dbWriteTable(conn = db, name = "samples", + data.frame(x = as.numeric(NA), + y = as.numeric(NA), + date = as.character(NA), + sample_type = as.character(NA), + animal = as.character(NA), + sex = as.character(NA), + sample_name = as.character(NA), + reference_sample = as.character(NA))[0, ]) +} + +if (file.exists(data.parentage)) { + # TODO: We may want to implement some sanity checks (e.g. check proper column names, types). + prt <- read.table(data.parentage, header = TRUE, sep = ",", comment.char = "") + dbWriteTable(conn = db, name = "parentage", prt) +} else { + # If input files are not present, add empty table. + dbWriteTable(conn = db, name = "parentage", + data.frame(offsprint = as.character(NA), + mother = as.character(NA), + father = as.character(NA), + cluster = as.numeric(NA))[0, ]) +} + From 956db0ce3c1aa7f8fd859f5990b72c4b62c9e059 Mon Sep 17 00:00:00 2001 From: romunov Date: Sat, 6 Apr 2019 10:15:28 +0200 Subject: [PATCH 2/2] Pretty code, remov print statements, translat some comments to Slovene --- R/base_body.R | 1 - R/create_variables.R | 5 +--- R/functions.R | 49 +++++++++-------------------------- R/map_add_mcp.R | 13 ++++------ R/plot_pedigree.R | 13 +++------- R/ui_render_floating_inputs.R | 6 ++--- R/ui_render_settings_colors.R | 5 ++-- R/ui_render_statistics.R | 1 - 8 files changed, 26 insertions(+), 67 deletions(-) diff --git a/R/base_body.R b/R/base_body.R index ed65b57..6cbf8e2 100644 --- a/R/base_body.R +++ b/R/base_body.R @@ -6,7 +6,6 @@ body <- dashboardBody( tags$head( # Include our custom CSS includeCSS("./css/styles.css") - # includeScript("gomap.js") ), leafletOutput("map"), absolutePanel(id = "controls", class = "panel panel-default", fixed = TRUE, diff --git a/R/create_variables.R b/R/create_variables.R index 3424b0a..627dff2 100644 --- a/R/create_variables.R +++ b/R/create_variables.R @@ -42,7 +42,7 @@ mortality <- reactive({ } }) -# Filter out offspring from data +# Filter out offspring from data. fOffs <- reactive({ xy <- fData() x <- unique(wolfPicks()$reference_sample) @@ -78,7 +78,4 @@ getCluster <- reactive({ xy$reference_sample %in% kls$father, ] return(out[, "reference_sample"]) } - - - }) diff --git a/R/functions.R b/R/functions.R index 97ad94b..7153bdf 100644 --- a/R/functions.R +++ b/R/functions.R @@ -9,11 +9,12 @@ GKtoWGS <- function(df) { names(df)[grepl("^y$|^Y$", names(df))] <- "y" # Detect if coordinates are in GK or WGS - if (mean(nchar(as.integer(abs(df$x)))) > 3) { # If coords are in GK, convert them to WGS, otherwise let them be + # If coords are in GK, convert them to WGS, otherwise let them be. + if (mean(nchar(as.integer(abs(df$x)))) > 3) { coordinates(df) <- ~ x + y - proj4string(df) <- CRS("+init=epsg:3912") # EPSG:3912 - WGS <- CRS("+init=epsg:4326") # WGS84 + proj4string(df) <- CRS("+init=epsg:3912") # EPSG:3912 + WGS <- CRS("+init=epsg:4326") # WGS84 converted <- spTransform(df, WGS) df$lng <- converted$x @@ -89,10 +90,11 @@ customSentence <- function(numItems, type) { paste("Currently displaying") } + #' Function to call in place of dropdownMenu dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"), - badgeStatus = "primary", icon = NULL, .list = NULL, customSentence = customSentence) -{ + badgeStatus = "primary", icon = NULL, .list = NULL, + customSentence = customSentence) { type <- match.arg(type) if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus) items <- c(list(...), .list) @@ -142,7 +144,7 @@ calChull <- function(x) { coordinates(x) <- ~ lng + lat point <- SpatialPoints(x) - # convert to UTM to have buffer in sensible units + # Cnvert to UTM to have buffer in sensible units. initcrs <- CRS("+init=epsg:4326") proj4string(point) <- initcrs point <- spTransform(point, CRSobj = CRS("+init=epsg:3912")) @@ -159,10 +161,10 @@ calChull <- function(x) { lines <- Lines(slinelist = list(line), ID = "1") s.line <- SpatialLines(LinesList = list(lines)) - # convert to UTM to have buffer in sensible units + # Convert to UTM to have buffer in sensible units. proj4string(s.line) <- initcrs s.line <- spTransform(s.line, CRSobj = CRS("+init=epsg:3912")) - mcp <- gBuffer(s.line, width = 1000) # buffer of 1 km + mcp <- gBuffer(s.line, width = 1000) # buffer of 1 km mcp <- spTransform(mcp, CRSobj = initcrs) return(mcp) @@ -183,12 +185,7 @@ calChull <- function(x) { #' @param samples A data.frame with samples data #' @param data A data.frame with parentage data #' @param cluster Selected cluster - - fillSexAndStatus <- function(samples, data, cluster) { - - # browser() - samples$sex <- as.character(samples$sex) # kinship2 needs sex data in that form. @@ -198,44 +195,24 @@ fillSexAndStatus <- function(samples, data, cluster) { fam <- data[data$cluster == cluster, ] # subset data by cluster - # for (i in 1:nrow(fam)) { - # if (nchar(fam$mother[i]) == 0) { - # virtual.mother <- paste("UM", i, sep = "") - # fam$mother[i] <- virtual.mother - # add.virtual.mother <- c(virtual.mother, "", "", cluster) - # fam <- rbind(fam, add.virtual.mother) - # } - # if (nchar(fam$father[i]) == 0) { - # virtual.father <- paste("UF", i, sep = "") - # fam$father[i] <- virtual.father - # add.virtual.father <- c(virtual.father, "", "", cluster) - # fam <- rbind(fam, add.virtual.father) - # } - # } - - members <- na.omit(unique(unlist(fam[ , c("offspring", "father", "mother")]))) # find all cluster members members <- members[nchar(members) > 0] no.parents <- members[!(members %in% fam$offspring)] # find members without known parents - # # print(paste("Found", length(no.parents), "animals without known parents.", sep = " ")) - - # fill empty parents to those members + # Fill empty parents to those members. for (i in no.parents) { add.parents <- c(i, "", "", cluster) fam <- rbind(fam, add.parents) } - # print(paste("Family has", nrow(fam), "members.", sep = " ")) - # v podatkih o vzorcih poišči podatke o spolu članov družine sex_data <- unique(samples[samples$reference_sample %in% members, c("reference_sample", "sex")]) dead_animals <- samples[samples$sample_type %in% c("Decomposing Tissue", "Tissue") & samples$reference_sample %in% members, c("reference_sample")] - # pridruži podatke o spolu + # Add data on sex. data <- merge(x = fam, y = sex_data, by.x = "offspring", by.y = "reference_sample", all = TRUE) data$sex[grep(pattern = "[*]", x = data$offspring, ignore.case = TRUE)] <- "male" @@ -245,7 +222,5 @@ fillSexAndStatus <- function(samples, data, cluster) { data$status <- 0 data$status[data$offspring %in% dead_animals] <- 1 - # print(paste(length(dead_animals), "known dead animal(s) in the family.", sep = " ")) - data } diff --git a/R/map_add_mcp.R b/R/map_add_mcp.R index bb330f6..b7d93a9 100644 --- a/R/map_add_mcp.R +++ b/R/map_add_mcp.R @@ -6,8 +6,7 @@ observe({ if (is.null(mcpIn)) { return(NULL) } if (mcpIn) { - # get data for all selected animals, adult and otherwise - # prepare parents data + # Get data for all selected animals, adult and otherwise prepare parents data. parent <- wolfPicks() xy <- addParentageData(x = parent, parents = inputFileParentage()) @@ -43,7 +42,7 @@ observe({ mcp.centroid <- sapply(mcp, FUN = gCentroid) } - # renumber IDs, modified from https://gis.stackexchange.com/a/234030 + # Renumber IDs, modified from https://gis.stackexchange.com/a/234030 nms <- names(ani.list) mcp <- lapply(1:length(mcp), function(i, mcp, nms) { spChFIDs(mcp[[i]], nms[i]) @@ -58,7 +57,7 @@ observe({ levels = c("parent", "offspring"), ordered = TRUE) - # find unique class of polygons - which corresponds to list element in xy + # Find unique class of polygons - which corresponds to list element in xy. xy.class <- sapply(ani.list, FUN = function(x) {unique(x$class)}) xy.class <- sapply(xy.class, "[", 1) @@ -82,10 +81,10 @@ observe({ for (i in cent.parents) { # If parent has any offspring (selected), connect centroids as described above. - num.offspring <- xy[xy$mother %in% i | xy$father %in% i, ] # find all offspring for parent i + num.offspring <- xy[xy$mother %in% i | xy$father %in% i, ] # find all offspring for parent i if (nrow(num.offspring) > 0) { - cent.i.offspring <- unique(num.offspring$reference_sample) # isolate offspring animals + cent.i.offspring <- unique(num.offspring$reference_sample) # isolate offspring animals for (j in cent.i.offspring) { if (any(names(mcp.centroid) %in% j)) { @@ -101,8 +100,6 @@ observe({ } } } - - } else { leafletProxy(mapId = "map") %>% clearGroup(group = "MCP") diff --git a/R/plot_pedigree.R b/R/plot_pedigree.R index cd717a4..51f4a54 100644 --- a/R/plot_pedigree.R +++ b/R/plot_pedigree.R @@ -1,16 +1,13 @@ observe({ - if (is.null(input$plot.pedigree)) return(NULL) if (input$plot.pedigree == TRUE && input$cluster != "all") { - - samples <- inputFileSamples() relations <- inputFileParentage() cluster <- input$cluster family <- fillSexAndStatus(samples, relations, cluster) - # izdelaj pedigree + # Make pedigree. pdgr <- pedigree(id = family$offspring, dadid = family$father, momid = family$mother, @@ -25,9 +22,8 @@ observe({ col = "#31a354") }) - # this answer helped with collapsible panel + # This answer helped with collapsible panel # https://stackoverflow.com/questions/35175167/collapse-absolutepanel-in-shiny/35175847 - output$pedigree.panel <- renderUI({ absolutePanel(id = "pedigree", class = "panel panel-default", fixed = TRUE, draggable = FALSE, top = "auto", left = 250, right = "auto", bottom = 10, @@ -41,9 +37,8 @@ observe({ } if (input$plot.pedigree == FALSE) { output$pedigree.panel <- renderUI({ NULL }) - } + } if (input$cluster == "all") { output$pedigree.panel <- renderUI({ NULL }) - } + } }) - diff --git a/R/ui_render_floating_inputs.R b/R/ui_render_floating_inputs.R index 47004b8..6100a65 100644 --- a/R/ui_render_floating_inputs.R +++ b/R/ui_render_floating_inputs.R @@ -65,7 +65,7 @@ observe({ }) # If familial/cluster data is available, create a menu which -# offers to filters out only animals from selected cluster +# offers to filters out only animals from selected cluster. observe({ xy <- inputFileParentage() if ((nrow(xy) > 0) & (length(unique(xy$cluster)) > 1)) { @@ -79,9 +79,7 @@ observe({ }) observe({ - if(!is.null(input$cluster) && input$cluster != "all") - # if(length(input$cluster) > 0) - { + if(!is.null(input$cluster) && input$cluster != "all") { output$pedig.plot <- renderUI({ checkboxInput(inputId = "plot.pedigree", label = "Plot pedigree", value = FALSE) }) diff --git a/R/ui_render_settings_colors.R b/R/ui_render_settings_colors.R index bfd8b09..10e13d5 100644 --- a/R/ui_render_settings_colors.R +++ b/R/ui_render_settings_colors.R @@ -33,16 +33,15 @@ observe({ } }) -# if a new color is picked, update the data.frame +# If a new color is picked, update the data.frame. observe({ if (nrow(allData()) > 0) { for (i in colors.df$mapping$ui_name) { - # print(sprintf("working with %s", colors.df[colors.df$ui_name == i, "sample_type_levels"])) new.color <- input[[i]] if (!is.null(new.color)) { current.color <- as.character(colors.df$mapping[colors.df$mapping$ui_name == i, "sample_type_colors"]) if (new.color != current.color) { - # if colors do not match, update old color with new color + # If colors do not match, update old color with new color. colors.df$mapping[colors.df$mapping$ui_name == i, "sample_type_colors"] <- new.color } } diff --git a/R/ui_render_statistics.R b/R/ui_render_statistics.R index 9992d86..83e8493 100644 --- a/R/ui_render_statistics.R +++ b/R/ui_render_statistics.R @@ -44,7 +44,6 @@ observe({ offs <- data.frame(count(par.tidy, "value")) # Get number of offspring per parent clust <- data.frame(count(par, "cluster")) - if (nrow(allData()) > 0) { output$sps <- renderDataTable({ sam_typ