diff options
| -rw-r--r-- | gn/data/strains.scm | 22 | ||||
| -rw-r--r-- | gn/db/mysql.scm | 78 | ||||
| -rwxr-xr-x | scripts/precompute/precompute-hits.scm | 55 |
3 files changed, 131 insertions, 24 deletions
diff --git a/gn/data/strains.scm b/gn/data/strains.scm new file mode 100644 index 0000000..275c4cd --- /dev/null +++ b/gn/data/strains.scm @@ -0,0 +1,22 @@ +(define-module (gn data strains) + #:use-module (json) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 iconv) + #:use-module (ice-9 receive) + #:use-module (ice-9 string-fun) + ;; #:use-module (gn db sparql) + #:use-module (dbi dbi) + #:use-module (gn db mysql) + #:use-module (gn data group) + #:use-module (web gn-uri) + + #:export ( + strain-names + )) + +(define (strain-names) + (call-with-db + (lambda (db) + (dbi-query db "SELECT StrainId,Strain.Name FROM Strain, StrainXRef WHERE StrainXRef.StrainId = Strain.Id AND StrainXRef.InbredSetId = 1 AND Used_for_mapping='Y' ORDER BY StrainId;") + (get-rows-apply db (lambda (r) `(,(assoc-ref r "StrainId") . ,(assoc-ref r "Name"))) '())))) diff --git a/gn/db/mysql.scm b/gn/db/mysql.scm index f6513af..4c6b35e 100644 --- a/gn/db/mysql.scm +++ b/gn/db/mysql.scm @@ -13,13 +13,50 @@ #:use-module (dbi dbi) #:export ( + ;; DB <- don't export + call-with-db + db-open db-check + db-check2 + db-query + db-get-row + get-row db-display-rows db-get-rows db-get-rows-apply + get-rows-apply )) -(define (db-check db) +(define DB + (begin + (display "===> OPENING DB") + (newline) + (dbi-open "mysql" "webqtlout:webqtlout:db_webqtl:tcp:127.0.0.1:3306") + )) + +(define (db-open) + DB) + +(define (db-open2) + (begin + (display "===> OPENING DB") + (newline) + (dbi-open "mysql" "webqtlout:webqtlout:db_webqtl:tcp:127.0.0.1:3306") + )) + +(define (call-with-db thunk) + (thunk (db-open2))) + +(define (db-check) + "Use DBI-style handle to report an error. On error the program will stop." + (match (dbi-get_status DB) + ((stat . msg) (if (= stat 0) + #t + (begin + (display msg) + (newline) + (assert stat)))))) +(define (db-check2 db) "Use DBI-style handle to report an error. On error the program will stop." (match (dbi-get_status db) ((stat . msg) (if (= stat 0) @@ -29,16 +66,25 @@ (newline) (assert stat)))))) -(define (db-display-rows db) +(define (db-query str) + (dbi-query (pk DB) str)) + +(define (db-get-row) + (dbi-get_row DB)) + +(define (get-row db) + (dbi-get_row db)) + +(define (db-display-rows) (let [(row (dbi-get_row db))] (if row (begin (display row) - (get-rows db) + (get-rows DB) ) #t))) -(define (db-get-rows db list) +(define (db-get-rows list) "After running dbi-query we can fetch all rows and return them as a list of records, which are assoc list: (dbi-query db \"SELECT StrainId,Strain.Name FROM Strain, StrainXRef WHERE StrainXRef.StrainId = Strain.Id AND StrainXRef.InbredSetId = 1 ORDER BY StrainId;\") @@ -47,18 +93,32 @@ (((StrainId . 4) (Name . BXD1)) ((StrainId . 5) (Name . BXD2))... " - (let [(row (dbi-get_row db))] + (let [(row (dbi-get_row DB))] (if row - (db-get-rows db (append list `(,row))) + (db-get-rows (append list `(,row))) list))) -(define (db-get-rows-apply db func list) +(define (db-get-rows-apply func list) "Similar to db-get-rows with a function that gets applied on every record, e.g. (define ids (db-get-rows-apply db (lambda (r) `(,(assoc-ref r \"StrainId\") . ,(assoc-ref r \"Name\"))) '())) " - (let [(row (dbi-get_row db))] + (let [(row (dbi-get_row DB))] (if row - (db-get-rows-apply db func (append list `(,(func row)))) + (db-get-rows-apply func (append list `(,(func row)))) list))) + +(define (get-rows-apply db func lst) + "Similar to db-get-rows with a function that gets applied on every record, e.g. + + (define ids (db-get-rows-apply db (lambda (r) `(,(assoc-ref r \"StrainId\") . ,(assoc-ref r \"Name\"))) '())) + +" + (let [(row (dbi-get_row db))] + (begin + (display row) + (if row + (get-rows-apply db func (append lst `(,(func row)))) + lst))) +) diff --git a/scripts/precompute/precompute-hits.scm b/scripts/precompute/precompute-hits.scm index cc26a9a..5955fb1 100755 --- a/scripts/precompute/precompute-hits.scm +++ b/scripts/precompute/precompute-hits.scm @@ -6,6 +6,7 @@ (use-modules (dbi dbi) (gn db mysql) + (gn data strains) (rnrs base) (ice-9 match) ) @@ -14,22 +15,46 @@ ;; ;; mysql -uwebqtlout -pwebqtlout -A -h 127.0.0.1 -P 3306 db_webqtl -e "show tables;" ;; -(define db (dbi-open "mysql" "webqtlout:webqtlout:db_webqtl:tcp:127.0.0.1:3306")) -(db-check db) -(dbi-query db "SELECT * FROM ProbeSetXRef LIMIT 3") -(db-check db) -; (display (dbi-get_status db_webqtl)) -(let [(row (dbi-get_row db))] + +#! +(db-query "SELECT * FROM ProbeSetXRef LIMIT 3") +(db-check) +(let [(row (db-get-row))] (display row) ) +!# -(dbi-query db "SELECT StrainId,Strain.Name FROM Strain, StrainXRef WHERE StrainXRef.StrainId = Strain.Id AND StrainXRef.InbredSetId = 1 AND Used_for_mapping='Y' ORDER BY StrainId;") -(db-check db) - -(define ids (db-get-rows-apply db (lambda (r) `(,(assoc-ref r "StrainId") . ,(assoc-ref r "Name"))) '())) +(call-with-db + (lambda (db) + (begin + (dbi-query db "SELECT * FROM ProbeSetXRef LIMIT 3") + (let [(row (get-row db))] + (display row) + ) + (newline) + (dbi-query db "SELECT * FROM ProbeSetXRef LIMIT 3") + (let [(row (get-row db))] + (display row) + ) + (newline) + (dbi-query db "SELECT StrainId,Strain.Name FROM Strain, StrainXRef WHERE StrainXRef.StrainId = Strain.Id AND StrainXRef.InbredSetId = 1 AND Used_for_mapping='Y' ORDER BY StrainId;") + (let [(row (get-row db))] + (display row) + ) + (let [(result (get-rows-apply db (lambda (r) `(,(assoc-ref r "StrainId") . ,(assoc-ref r "Name"))) '()))] + (display (car result))) -(newline) -(display (car ids)) -(newline) -(display (assoc 5 ids)) -(newline) + (newline) + (display (strain-names)) + ; (display (car ids)) + (newline) + ; (display (assoc 5 ids)) + (newline) + (newline) + (dbi-query db "SELECT * FROM ProbeSetXRef LIMIT 3") + (let [(row (get-row db))] + (display row) + ) + (db-check2 db) + (newline) +))) |