Skip to content
This repository has been archived by the owner on Oct 12, 2022. It is now read-only.

Commit

Permalink
allow selecting individual species for PAM subset.
Browse files Browse the repository at this point in the history
  • Loading branch information
@benanhalt
benanhalt committed Jul 19, 2018
1 parent a1b3932 commit 4c6338c
Showing 1 changed file with 77 additions and 32 deletions.
109 changes: 77 additions & 32 deletions source/SubsetPam.elm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ port module SubsetPam exposing (..)

import Set exposing (Set)
import Dict exposing (Dict)
import Json.Decode as Json
import Html exposing (Html)
import Html.Events as Events
import Html.Attributes
Expand All @@ -39,7 +40,7 @@ port bboxSelected : (List Float -> msg) -> Sub msg

type alias Facets =
{ algorithms : Set String
, displayNames : Set String
, displayNames : Set ( String, String )
, modelScenarios : Set String
, projectionScenarios : Set String
, taxonClass : Set String
Expand Down Expand Up @@ -78,7 +79,8 @@ initFacets =
type alias Model =
{ facets : Facets
, filters : Dict String String
, pavs : String
, selectedSpecies : Maybe (List String)
, pavs : List SolrPAV
, shapeGrid : Maybe String
, loadingPavs : Bool
, archiveName : String
Expand All @@ -100,6 +102,7 @@ type Msg
| GotShapeGrid String
| SetFilter String String
| ClearFilter String
| SpeciesSelected (List String)
| SetArchiveName String
| BBoxSelected (List Float)
| RunMCPA
Expand Down Expand Up @@ -157,7 +160,7 @@ view model =
[ Html.text "Processing complete. "
, Html.a
[ Html.Attributes.href <|
"http://gad210.nchc.org.tw/api/v2/gridset/"
"http://notyeti-193.lifemapper.org/api/v2/gridset/"
++ (toString id)
++ "/package"
]
Expand All @@ -173,8 +176,15 @@ header loadingPavs =
Html.text "Subset PAM with these filters"


speciesSelected : Json.Decoder Msg
speciesSelected =
(Json.at [ "target", "selectedOptions" ] <| Json.keyValuePairs <| Json.maybe (Json.field "value" Json.string))
|> Json.map (List.filterMap Tuple.second)
|> Json.map SpeciesSelected


viewNotPosted : Model -> Html Msg
viewNotPosted { facets, filters, pavs, shapeGrid, loadingPavs, archiveName } =
viewNotPosted { facets, filters, selectedSpecies, pavs, shapeGrid, loadingPavs, archiveName } =
Html.div [ Html.Attributes.style [ ( "font-family", "sans-serif" ), ( "display", "flex" ), ( "justify-content", "space-around" ) ] ]
[ Html.div []
[ Html.h3 [] [ header loadingPavs ]
Expand Down Expand Up @@ -233,8 +243,12 @@ viewNotPosted { facets, filters, pavs, shapeGrid, loadingPavs, archiveName } =
]
]
, Html.h3 [] [ Html.text "Matching species" ]
, Html.ul [ Html.Attributes.style [ ( "height", "400px" ), ( "overflow-y", "auto" ), ( "border", "1px solid grey" ) ] ]
(List.map displayName <| Set.toList facets.displayNames)
, Html.select
[ Html.Attributes.style [ ( "height", "400px" ), ( "width", "800px" ) ]
, Html.Attributes.multiple True
, Events.on "change" speciesSelected
]
(List.map (displayName selectedSpecies) <| Set.toList facets.displayNames)
, Html.div []
[ Html.input
[ Html.Attributes.placeholder "Archive name"
Expand All @@ -254,7 +268,7 @@ viewNotPosted { facets, filters, pavs, shapeGrid, loadingPavs, archiveName } =
[ Html.h3 [] [ Html.text "Heat map of matching species" ]
, Html.div
[ Html.Attributes.class "leaflet-map"
, Html.Attributes.attribute "data-map-pavs" pavs
, Html.Attributes.attribute "data-map-pavs" <| filterAndJoinPavs selectedSpecies pavs
, Html.Attributes.attribute "data-map-shape-grid" <| Maybe.withDefault "" <| shapeGrid
, Html.Attributes.style [ ( "width", "800px" ), ( "height", "800px" ) ]
]
Expand All @@ -263,17 +277,42 @@ viewNotPosted { facets, filters, pavs, shapeGrid, loadingPavs, archiveName } =
]


displayName : String -> Html Msg
displayName name =
Html.li [] [ Html.text name ]
filterAndJoinPavs : Maybe (List String) -> List SolrPAV -> String
filterAndJoinPavs selectedSpecies pavs =
let
filterBySpecies =
case selectedSpecies of
Just squids ->
List.filter (\(SolrPAV { squid }) -> List.member squid squids)

Nothing ->
identity
in
pavs
|> filterBySpecies
|> List.map (\(SolrPAV { compressedPAV }) -> compressedPAV)
|> String.join "\n"


displayName : Maybe (List String) -> ( String, String ) -> Html Msg
displayName selectedSpecies ( name, squid ) =
let
selected =
Maybe.map (List.member squid) selectedSpecies |> Maybe.withDefault False
in
Html.option [ Html.Attributes.value squid, Html.Attributes.selected selected ]
[ Html.text name ]


updateFilters : Dict String String -> Model -> ( Model, Cmd Msg )
updateFilters filters model =
if Dict.member "taxonKingdom" filters then
( { model | filters = filters, loadingPavs = True }, getSolrList filters )
else
( { model | facets = initFacets, filters = filters }, Cmd.none )
-- if Dict.member "taxonKingdom" filters then
( { model | filters = filters, loadingPavs = True, selectedSpecies = Nothing }, getSolrList filters )



-- else
-- ( { model | facets = initFacets, filters = filters }, Cmd.none )


update : Msg -> Model -> ( Model, Cmd Msg )
Expand All @@ -286,11 +325,8 @@ update msg model =
let
facets =
List.foldr addAttrs initFacets pavs

pavsJoined =
pavs |> List.map (\(SolrPAV { compressedPAV }) -> compressedPAV) |> String.join "\n"
in
( { model | facets = facets, pavs = pavsJoined, loadingPavs = False }, Cmd.none )
( { model | facets = facets, pavs = pavs, loadingPavs = False }, Cmd.none )

GotShapeGrid shp ->
( { model | shapeGrid = Just shp }, Cmd.none )
Expand All @@ -301,14 +337,19 @@ update msg model =
ClearFilter key ->
updateFilters (Dict.remove key model.filters) model

SpeciesSelected squids ->
( { model | selectedSpecies = Just squids }, Cmd.none )

SetArchiveName name ->
( { model | archiveName = String.trim name }, Cmd.none )

BBoxSelected bbox ->
updateFilters (Dict.insert "bbox" (bbox |> List.map toString |> String.join ",") model.filters) model

RunMCPA ->
( { model | postStatus = Posted }, runMCPA model.archiveName model.filters )
( { model | postStatus = Posted }
, runMCPA model.archiveName model.filters (model.selectedSpecies |> Maybe.withDefault [])
)

GotPostResponse result ->
case result of
Expand Down Expand Up @@ -349,7 +390,7 @@ addAttrs (SolrPAV pav) facets =
attr |> Maybe.map (\a -> Set.insert a facet) |> Maybe.withDefault facet
in
{ algorithms = maybeInsert pav.algorithmCode facets.algorithms
, displayNames = Set.insert pav.displayName facets.displayNames
, displayNames = Set.insert ( pav.displayName, pav.squid ) facets.displayNames
, modelScenarios = maybeInsert pav.modelScenarioCode facets.modelScenarios
, projectionScenarios = maybeInsert pav.sdmProjScenarioCode facets.projectionScenarios
, taxonKingdom = maybeInsert pav.taxonKingdom facets.taxonKingdom
Expand All @@ -367,7 +408,7 @@ checkStatus id =
Http.request
{ method = "GET"
, headers = [ Http.header "Accept" "application/json" ]
, url = "http://gad210.nchc.org.tw/api/v2/gridset/" ++ (toString id)
, url = "http://notyeti-193.lifemapper.org/api/v2/gridset/" ++ (toString id)
, body = Http.emptyBody
, expect = Http.expectJson Decoder.decodeGridSet
, timeout = Nothing
Expand All @@ -391,7 +432,7 @@ getShapeGrid =
Http.request
{ method = "GET"
, headers = [ Http.header "Accept" "application/json" ]
, url = "http://gad210.nchc.org.tw/api/v2/shapegrid/33341/geojson"
, url = "http://notyeti-193.lifemapper.org/api/v2/shapegrid/92107/geojson"
, body = Http.emptyBody
, expect = Http.expectString
, timeout = Nothing
Expand All @@ -410,21 +451,24 @@ gotShapeGrid result =
Debug.crash (toString err)


runMCPA : String -> Dict String String -> Cmd Msg
runMCPA archiveName filters =
runMCPA : String -> Dict String String -> List String -> Cmd Msg
runMCPA archiveName filters selectedSpecies =
let
query =
queryWithFilters =
filters
|> Dict.insert "archiveName" archiveName
|> Dict.insert "gridSetId" "127"
|> Dict.insert "gridSetId" "77"
|> Dict.insert "user" "public"
|> Dict.foldr Q.add Q.empty
|> Q.render

query =
selectedSpecies
|> List.foldl (Q.add "squid") queryWithFilters
in
Http.request
{ method = "POST"
, headers = [ Http.header "Accept" "application/json" ]
, url = "http://gad210.nchc.org.tw/api/v2/globalPam" ++ query
, url = "http://notyeti-193.lifemapper.org/api/v2/globalPam" ++ (Q.render query)
, body = Http.emptyBody
, expect = Http.expectJson Decoder.decodeAtomObject
, timeout = Nothing
Expand All @@ -438,15 +482,15 @@ getSolrList filters =
let
query =
filters
|> Dict.insert "gridsetid" "127"
|> Dict.insert "gridsetid" "77"
|> Dict.insert "user" "public"
|> Dict.foldr Q.add Q.empty
|> Q.render
in
Http.request
{ method = "GET"
, headers = [ Http.header "Accept" "application/json" ]
, url = "http://gad210.nchc.org.tw/api/v2/globalPam" ++ query
, url = "http://notyeti-193.lifemapper.org/api/v2/globalPam" ++ query
, body = Http.emptyBody
, expect = Http.expectJson Decoder.decodeSolrList
, timeout = Nothing
Expand All @@ -469,13 +513,14 @@ init : ( Model, Cmd Msg )
init =
{ facets = initFacets
, filters = Dict.empty
, pavs = ""
, selectedSpecies = Nothing
, pavs = []
, shapeGrid = Nothing
, loadingPavs = False
, archiveName = ""
, postStatus = NotPosted
}
! [ getShapeGrid ]
! [ getShapeGrid, getSolrList Dict.empty ]


subscriptions : Model -> Sub Msg
Expand Down

0 comments on commit 4c6338c

Please sign in to comment.